Excel als Report-Generator - Teil 1

Anmerkungen zum Code

Der Code zum Druck eines einfachen Berichts ist in Listing 1 abgedruckt. Die Verwendung dieser Funktion beziehungsweise dessen Aufruf zeigt Listing 2. Die Hauptfunktion erwartet drei Parameter:

'# HEADER: ************************************************
'- Funktion ____ FUR_PrintOut
'- Kurzinfo ____ Flexible Berichte mit Excel drucken
'- Autor _______ Michael W. Welling - TECTUM SoftwareDESIGN
'- Erstellung __ Version 001 - 12.12.2005 00:00:00
'**********************************************************
Public _
Function FUR_PrintOut( _
ByVal DataSource As DAO.Recordset, _
ByVal ProfileKey As String, _
Optional ByVal PrintDirectly As Boolean = False) As Long
On Error GoTo RunError
Dim sql As String
'**********************************************************
'* Plausibilitätskontrollen
If DataSource Is Nothing = True Then Exit Function
If DataSource.RecordCount = 0 Then Exit Function
'*******************************************************
'* aktuelle Datenbank referenzieren
Dim dbs As DAO.Database
Set dbs = CurrentDb()
'*******************************************************
'* Datei-Pfad und -Namen aus den Profildaten ermitteln
'* Auswahl-Abfrage generieren
sql = ""
sql = sql & "SELECT"
sql = sql & " *"
sql = sql & " FROM"
sql = sql & " [USys_FUR_Profile]"
sql = sql & " WHERE"
sql = sql & " [ProfileKey]='" & ProfileKey & "'"
sql = sql & " AND"
sql = sql & " [activated]=-1"
sql = sql & ";"
'*******************************************************
'* wurden Profildaten gefunden?
Dim mta As DAO.Recordset
Set mta = dbs.OpenRecordset(sql, dbOpenDynaset)
If mta.RecordCount = 0 Then
mta.Close
dbs.Close
FUR_PrintOut = 1
GoTo RunError
End If
'*******************************************************
'* Dateiname der Berichts-Datei ermitteln
Dim ReportFile As String
ReportFile = mta![ReportFile]
If ReportFile & "" = "" Then
FUR_PrintOut = 3
GoTo RunError
End If
'* relativen Pfad der Berichts-Datei ermitteln
Dim ReportPath As String
ReportPath = mta![ReportPath]
'* Tabelle schliessen
mta.Close
'*******************************************************
'* aktuellen Pfad der Datenbank ermitteln
Dim seperator As String
seperator = "\"
Dim pos As Long
pos = 0
Dim DBPath As String
DBPath = dbs.Name
Dim CurPath As String
pos = InStr(1, DBPath, seperator)
While pos > 0
CurPath = Left(DBPath, pos - 1)
pos = InStr(pos + 1, DBPath, seperator)
Wend
'*******************************************************
'* Komplette Pfadangabe zusammenbauen
'* (Netzwerk-Pfade berücksichtigen)
Dim FileName As String
FileName = ""
If Left(ReportPath, 2) = "\\" Then
FileName = FileName & ReportPath
ElseIf Left(ReportPath, 1) = "\" Then
FileName = FileName & CurPath
FileName = FileName & ReportPath
Else
FileName = FileName & ReportPath
End If
FileName = FileName & "\"
FileName = FileName & ReportFile
'* Instanz von Excel erstellen
Dim off_exc As Object
Set off_exc = CreateObject("Excel.Application")
'* xls-Datei öffnen
Dim exc_wkb As Object
Set exc_wkb = off_exc.Workbooks.Open( _
FileName:=FileName, _
ReadOnly:=False, _
Editable:=True)
'*******************************************************
'* Meta-Daten ermitteln
sql = ""
sql = sql & "SELECT"
sql = sql & " *"
sql = sql & " FROM"
sql = sql & " [USys_FUR_Field]"
sql = sql & " WHERE"
sql = sql & " [ProfileKey]='" & ProfileKey & "'"
sql = sql & " AND"
sql = sql & " [activated]=-1"
sql = sql & ";"
Set mta = Nothing
Set mta = dbs.OpenRecordset(sql, dbOpenDynaset)
If mta.RecordCount = 0 Then
mta.Close
dbs.Close
End If
'**********************************************************
'* Worksheet-Objekt-Variable definieren
Dim exc_wks As Object
'*******************************************************
'* Daten aus Tabelle in Report übertragen
Dim Sheet As String
Dim Row As Long
Dim col As Long
'* Für jeden Datensatz durchschleifen, ...
DataSource.MoveFirst
While Not DataSource.EOF
'* Für jedes Feld in Metadaten durchschleifen, ...
mta.MoveFirst
While Not mta.EOF
'* Feld-Name ermitteln
Dim FieldName As String
FieldName = mta![FieldName]
'* Zeile und Spalte müssen angegeben sein, ...
If (mta![Row] & "" <> "") And _
(mta![Column] & "" <> "") Then
'* Zeile ermitteln
Row = mta![Row]
'* Spalte ermitteln
col = mta![Column]
'* Arbeitsblatt ermitteln
Sheet = mta![Worksheet]
'* Seite im Excel-Sheet referenzieren
Set exc_wks = exc_wkb.Worksheets(Sheet)
'* Datum in Zelle einfügen
exc_wks.Cells(Row, col).Value = _
DataSource(FieldName)
End If
'* nächstes Feld
mta.MoveNext
Wend
'* nächsten Datensatz
Fortsetzung Listing 1
DataSource.MoveNext
Wend
'**********************************************************
'* Drucken oder Vorschau
Select Case PrintDirectly
Case True
exc_wks.PrintOut
exc_wkb.Close (False)
Case False
off_exc.Visible = True
exc_wks.Activate
End Select
RunError:
Select Case Err.Number
Case 0
Case 1004 '* Aktion abgebrochen
MsgBox "Zeile: " & Row & ", Spalte: " & col
Resume Next
Case Else
MsgBox Err.Description, _
vbCritical, _
"Nr. " & Err.Number
End Select
RunTerminate:
'* Excel wieder schlissen
Select Case PrintDirectly
Case True
If off_exc Is Nothing = False Then
off_exc.Quit
End If
Case False
End Select
'* Excel-Objekt-Variablen terminieren
Set exc_wks = Nothing
Set exc_wkb = Nothing
Set off_exc = Nothing
'* DAO-Objekt-Variablen terminieren
Set DataSource = Nothing
Set mta = Nothing
Set dbs = Nothing
End Function