Code Snippet "VBA Access"
Ränder eines Berichts (Druckeinstellungen) mit VBA einstellen
'Routinen zum Umstellen der Seitenränder eines Bericht in einer Ereignisprozedur
'Erstellt von Silvia Rothen, rothen ecotronics, 18.04.2007
'Ränder einstellen in Ereignisprozedur unter Access 2000
'Schwierigkeiten
' - In Report_Open kann man Report weder öffnen noch schliessen
' - In Report_Activate geht das, aber man landet in Endlosschleife
' da das Öffnen jedes Mal wieder ein Activate auslöst
' - Application.EnableEvents = False wie in Excel scheint nicht zu existieren
' - Application.ScreenUpdating = False?
' - Static-Variable in Ereignisprozedur geht auch nicht, wird immer zurückgesetzt
'Lösung
' - Ereignisprozedur Report_Activate
' - öffentliche Variable blnEingestellt im Modul _Druckeinstellungen
' Achtung: bei mehreren Berichten braucht es eine Variable pro Bericht!
' - Diverse Routinen im Modul _Druckeinstellungen
'******************************************************************************************
'Ereignisprozedur hinter dem Formular
Option Compare Database
Option Explicit
Private Sub Report_Activate()
Const links As Single = 12
Const oben As Single = 12
Const rechts As Single = 12
Const unten As Single = 12
Dim strName As String
strName = Me.Name
If blnrpt_a_infos = False Then
blnrpt_a_infos = True
DoCmd.Close acReport, strName, acSaveYes
Call RaenderEinstellen(strName, links, oben, rechts, unten)
If blnFilter Then
DoCmd.OpenReport strName, acPreview, , strFilter
strFilter = ""
blnFilter = False
Else
DoCmd.OpenReport strName, acViewPreview
End If
MsgBox ("Die Ränder wurden eingestellt" & vbCrLf & _
"Links: " & links & "mm" & vbCrLf & _
"Oben: " & oben & "mm" & vbCrLf & _
"Rechts: " & rechts & "mm" & vbCrLf & _
"Unten: " & unten & "mm" & vbCrLf _
)
End If
End Sub
'******************************************************************************************
'Modul _Druckeinstellungen
Option Compare Database
Option Explicit
'Diese Variable darf nicht hinter Report liegen, dort behält sie ihren Wert nicht
Public blnrpt_a_infos As Boolean
Public strFilter As String
Public blnFilter As Boolean
'567 Twip entsprechen 1 cm
Public Const TWIP_PRO_CM As Integer = 567
Type str_DEVMODE
strGZF As String * 94
End Type
Type type_DEVMODE
strDeviceName As String * 16
intSpecVersion As Integer
intDriverVersion As Integer
intSize As Integer
intDriverExtra As Integer
lngFields As Long
intOrientation As Integer
intPaperSize As Integer
intPaperLength As Integer
intPaperWidth As Integer
intScale As Integer
intCopies As Integer
intDefaultSource As Integer
intPrintQuality As Integer
intColor As Integer
intDuplex As Integer
intResolution As Integer
intTTOption As Integer
intCollate As Integer
strFormName As String * 16
lngPad As Long
lngBits As Long
lngPW As Long
lngPH As Long
lngDFI As Long
lngDFr As Long
End Type
Type str_PRTMIP
strGZF As String * 28
End Type
Type type_PRTMIP
xLeftMargin As Long
yTopMargin As Long
xRightMargin As Long
yBotMargin As Long
fDataOnly As Long
xWidth As Long
yHeight As Long
fDefaultSize As Long
cxColumns As Long
yColumnSpacing As Long
xRowSpacing As Long
rItemLayout As Long
fFastPrint As Long
fDatasheet As Long
End Type
Function TwipToMm(ByVal twip As Integer) As Single
TwipToMm = Round(twip * 10 / TWIP_PRO_CM, 2)
End Function
Function MmToTwip(ByVal mm As Single) As Integer
MmToTwip = Round(TWIP_PRO_CM * mm / 10, 0)
End Function
Sub BenutzerdefinierteSeitePrüfen(rptName As String)
Dim GeräteZF As str_DEVMODE
Dim DM As type_DEVMODE
Dim strGerätemodus As String
Dim rpt As Report
Dim intAntwort As Integer
' Den Bericht in der Entwurfsansicht öffnen.
DoCmd.OpenReport rptName, acDesign
Set rpt = Reports(rptName)
If Not IsNull(rpt.PrtDevMode) Then
strGerätemodus = rpt.PrtDevMode ' Die Struktur DEVMODE lesen.
GeräteZF.strGZF = strGerätemodus
LSet DM = GeräteZF
If DM.intPaperSize = 256 Then
' Die benutzerdefinierte Seitengröße anzeigen.
intAntwort = MsgBox("Die aktuelle" _
& "benutzerdefinierte Seite hat folgende Maße " _
& "Länge " & DM.intPaperLength / 100 _
& " cm, " _
& "Breite " & DM.intPaperWidth / 100 _
& " cm. " _
& "Möchten Sie diese Einstellungen ändern?", 4)
Else
' Die Maße sind momentan nicht benutzerdefiniert.
intAntwort = MsgBox("Der Bericht " _
& "hat keine benutzerdefinierte" _
& " Seitengröße." _
& "Möchten Sie eine definieren?", 4)
End If
If intAntwort = 6 Then
' Der Benutzer möchte die Einstellungen ändern.
' Das Element Fields initialisieren.
DM.lngFields = DM.lngFields Or _
DM.intPaperSize Or DM.intPaperLength _
Or DM.intPaperWidth
DM.intPaperSize = 256 ' Benutzerdefinierte Seite.
' Die Länge und die Breite abfragen.
DM.intPaperLength = _
InputBox("Geben Sie die Seitenlänge " _
& "in cm ein.") * 100
DM.intPaperWidth = _
InputBox("Geben Sie die Seitenbreite " _
& "in cm ein.") * 100
LSet GeräteZF = DM ' Die Eigenschaft aktualisieren.
Mid(strGerätemodus, 1, 94) = GeräteZF.strGZF
rpt.PrtDevMode = strGerätemodus
End If
End If
End Sub
Sub AusrichtungWechseln(strName As String)
Const DM_HOCHFORMAT = 1
Const DM_QUERFORMAT = 2
Dim GeräteZF As str_DEVMODE
Dim DM As type_DEVMODE
Dim strGerätemodus As String
Dim rpt As Report
' Den Bericht in der Entwurfsansicht öffnen.
DoCmd.OpenReport strName, acDesign
Set rpt = Reports(strName)
If Not IsNull(rpt.PrtDevMode) Then
strGerätemodus = rpt.PrtDevMode
GeräteZF.strGZF = strGerätemodus
LSet DM = GeräteZF
DM.lngFields = DM.lngFields Or DM.intOrientation ' Das Element Fields initialisieren.
If DM.intOrientation = DM_HOCHFORMAT Then
DM.intOrientation = DM_QUERFORMAT
Else
DM.intOrientation = DM_HOCHFORMAT
End If
LSet GeräteZF = DM ' Die Eigenschaft aktualisieren.
Mid(strGerätemodus, 1, 94) = GeräteZF.strGZF
rpt.PrtDevMode = strGerätemodus
End If
End Sub
Sub DruckeinstellungenAnzeigen(rptName As String)
Dim PrtMipZeichenfolge As str_PRTMIP
Dim PM As type_PRTMIP
Dim GeräteZF As str_DEVMODE
Dim DM As type_DEVMODE
Dim strGerätemodus As String
Dim rpt As Report
Dim intAntwort As Integer
' Den Bericht in der Entwurfsansicht öffnen.
DoCmd.OpenReport rptName, acDesign
Set rpt = Reports(rptName)
If Not IsNull(rpt.PrtDevMode) Then
strGerätemodus = rpt.PrtDevMode ' Die Struktur DEVMODE lesen.
GeräteZF.strGZF = strGerätemodus
LSet DM = GeräteZF
Debug.Print "Ausrichtung: " & DM.intOrientation
Debug.Print "Size: " & DM.intPaperSize
Debug.Print "intPaperLength: " & DM.intPaperLength
Debug.Print "intPaperWidth: " & DM.intPaperWidth
Debug.Print "intScale: " & DM.intScale
End If
PrtMipZeichenfolge.strGZF = rpt.PrtMip
LSet PM = PrtMipZeichenfolge
Debug.Print "xLeftMargin: " & TwipToMm(PM.xLeftMargin) & " mm"
Debug.Print "xRightMargin: " & TwipToMm(PM.xRightMargin) & " mm"
Debug.Print "yTopMargin: " & TwipToMm(PM.yTopMargin) & " mm"
Debug.Print "yBotMargin: " & TwipToMm(PM.yBotMargin) & " mm"
Debug.Print "xLeftMargin: " & PM.xLeftMargin & " TWIP"
End Sub
Sub RaenderEinstellen(ByVal strName As String, _
ByVal sngLeftInMm As Single, ByVal sngTopInMm As Single, ByVal sngRightInMm As Single, ByVal sngBottomInMm As Single)
Dim PrtMipZeichenfolge As str_PRTMIP
Dim PM As type_PRTMIP
Dim rpt As Report
DoCmd.OpenReport strName, acDesign 'gehört zu acFormView
Set rpt = Reports(strName)
PrtMipZeichenfolge.strGZF = rpt.PrtMip
LSet PM = PrtMipZeichenfolge
PM.xLeftMargin = MmToTwip(sngLeftInMm) ' Die Ränder auf übergebene mm einstellen
PM.yTopMargin = MmToTwip(sngTopInMm)
PM.xRightMargin = MmToTwip(sngRightInMm)
PM.yBotMargin = MmToTwip(sngBottomInMm)
LSet PrtMipZeichenfolge = PM ' Die Eigenschaft aktualisieren.
rpt.PrtMip = PrtMipZeichenfolge.strGZF
DoCmd.Close acReport, strName, acSaveYes
End Sub
Sub test()
Call DruckeinstellungenAnzeigen("rpt_KonjugationenPräs")
End Sub
Sub testRaender()
Call RaenderEinstellen("rpt_KonjugationenPräs", 12.01, 20.42, 12.01, 25.41)
'Call RaenderEinstellen("rpt_KonjugationenPräs", 11, 15, 11, 15)
End Sub