Sub GefDrucken
 
LZName= InName.Text
LZStrasse= InStrasse.Text
LZNr = InNr.Text
LZPLZ= InPLZ.Text
LZOrt= InOrt.Text
Set Test = CreateObject("Check.Class1")
Call Test.shGefahrenliste(LZName, LZStrasse, LZNr, LZPLZ, LZOrt)
End Sub

Public Sub shGefahrenliste(LZName1, LZStrasse1, LZNr1, LZPLZ1, LZOrt1)
'MsgBox "Name " & LZName1 & " • " & LZStrasse1 & " " & LZNr1 & " • " & LZPLZ1 & 
' " " & LZOrt1
 
'Untertitel erteilen
Bericht.Sections("Bereich2").Controls("Bezeichnung4").Caption = _
  "Gefährdungsanalyse Bericht der Name " & LZName1 & " • " & LZStrasse1 & " " & _
  LZNr1 & " • " & LZPLZ1 & " " & LZOrt1
 
Alles.Show 1
End Sub

Option Explicit
' this project requires a reference to Microsoft Active Data Objects 2.5 or 
' greater
Private RS As ADODB.Recordset
 
Private Sub Beenden_Click()
'Exit the program
Unload Me
Exit Sub
End Sub
 
Private Sub Form_Load()
 
'Create a RS
Dim RS As Recordset
Dim GefDB As String
Set RS = New Recordset
 
'Create a basic Sql string
Dim strSQL As String
strSQL = "SELECT * FROM Themen"
 
GefDB = App.Path
GefDB = getParentPath(GefDB)
 
'Open the Recordset
RS.Open strSQL, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GefDB & _
  "gefahr.mdb;Jet OLEDB:Database Password=xxxxx"
 
' substiture your own connected recordset here,
' it must not be foreward-only
'
If (RS.State = 0) Then
MsgBox "Recordset konnte nicht geöffnet werden"
Else
 
End If
 
While Not RS.EOF
Me.List1.AddItem RS.Fields("Thema")
 
RS.MoveNext
Wend
 
End Sub
 
Private Sub List1_Click()
 
'Create PageSet object
Dim obj As PageSet.PrinterControl
Dim GefDB As String
 
'Create a RS
Dim RS As Recordset
Set RS = New Recordset
 
'Create a basic Sql string
Dim strSQL As String
strSQL = "SELECT * FROM KATALOG WHERE USCHRIFT='" & Me.List1 & "' "
'MsgBox Me.List1
 
GefDB = App.Path
GefDB = getParentPath(GefDB)
 
'Open the Recordset
RS.Open strSQL, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GefDB & _
  "gefahr.mdb;Jet OLEDB:Database Password=xxxxx"
 
'Bind to the report
Set Bericht.DataSource = RS
 
Bericht.Sections("Bereich2").Controls("Bezeichnung3").Caption = "Thema: " & _
  Me.List1
 
'Set PageSet = Landscape
Set obj = New PrinterControl
obj.ChngOrientationLandscape
 
'Preview the report
Bericht.Show vbModal
 
'Cleanup
RS.Close
Set RS = Nothing
 
'Reset PageSet
obj.ReSetOrientation
 
End Sub
 
Private Sub Alles_Click()
'Create PageSet object
Dim obj As PageSet.PrinterControl
Dim GefDB As String
 
'Create a RS
Dim RS As Recordset
Set RS = New Recordset
 
'Create a basic Sql string
Dim strSQL As String
strSQL = "SELECT * FROM KATALOG"
'MsgBox Me.List1
 
GefDB = App.Path
GefDB = getParentPath(GefDB)
 
'Open the Recordset
RS.Open strSQL, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GefDB & _
  "gefahr.mdb;Jet OLEDB:Database Password=xxxxx"
 
'Bind to the report
Set Bericht.DataSource = RS
 
'Untertitel erteilen
Bericht.Sections("Bereich2").Controls("Bezeichnung3").Caption = "Klassifikation" & _
  "der Gefährdungsfaktoren"
 
'Set PageSet = Landscape
Set obj = New PrinterControl
obj.ChngOrientationLandscape
 
'Preview the report
Bericht.Show vbModal
 
'Cleanup
RS.Close
Set RS = Nothing
 
'Reset PageSet
obj.ReSetOrientation
End Sub
 
Private Sub Form1_Unload(Cancel As Integer)
 
'Create PageSet object
Dim obj As PageSet.PrinterControl
 
   obj.ReSetOrientation 'This resets the printer to portrait.
 
End Sub
 
' Übergeordneten Pfad aus Pfad-Angabe selektieren
Public Function getParentPath(strPath As String) As String
    Dim intPos As Integer
    If Right$(strPath, 1) = "\" Then
        strPath = Left$(strPath, Len(strPath) - 1)
    End If
    intPos = InStrRev(strPath, "\")
    If intPos > 0 Then
        getParentPath = Left$(strPath, intPos)
    End If
End Function