Exporter MS Access nach Excel. Die komplexe Version.

Eine kleine Klasse um schnell Daten aus Access nach Excel zu exportieren. Sie bietet die Möglichkeit, dann gleich noch einige Excel-Formatierungen durchzuführen

Meine erste Version [VBA][Access] XlsxExporter 1.0.1 ist zwar nicht schlecht, bietet mir aber zu wenig.

Darum hier die neue, bessere & komplexere Version 2.x

Um zu verstehen worum es geht und was die Klasse macht, empfehle ich zuerst einmal die Beispiele anzuschauen.

Im VBA musss eine Referenz auf 'MicrosoftExcel XY ObjectLibrary' gesetzt sein

In der folgenden Reihenfolge sollten die versch. Schritte aufgerufen werden. Kursiv geschrieben Punkte sind optional.

Bei einer anderen Reihenfolge kann es zu unerwarteten Resultaten führen.

1. Objekt erstellen/initialisieren
   1. Instanzieren mit initialize oder instance
   2. Paramters setzen, falls man das nicht bereits beim Instanzieren gemacht hat Enumerator xeParams
2. Formate definieren:
   1. Standardformat anpassen defaultFormat
   2. Standardformat auf alle vorfinierten Formate anpassen requeryDefaultFormats
   3. Dateitypenformate anpassen format
   4. Weitere Formate definieren format
3. Exportiere die Daten export
4. Formatierungen anwenden;
   1. Standartformat über das ganze Sheet doFormatDefault
   2. Spalten nach Datentyp doFormatColumnsByType
   3. Speziele andere Formate doFormat
5. Spezielle Anpassungen an Ranges range
6. Objekt abbauen (quit oder zerstören des Objektes)

Wird das Objekt terminiert, wird automatisch die Methode quit() ausgeführt. Die Änderungen werden dabei gespeichert und die internen Objekte (Excel-Instance,Workbook etc.) geschlossen und abgebaut. Die meisten Methoden und Properties sind im Code sauber beschrieben. Wie man sie anwendet sieht man in den Beispielen.

Die Formate sind einfache Excel-Ranges. Alle Formateigenschaften die ein Range haben kann, kann zugeordnet werden.

Beim terminate() der Klasse wird das Excelsheet gespeichert und die Excelinstanz geschlossen. Darum kann man das ganze in einem With-Plock handeln

Die folgenden Parameter exisitieren und können kombiniert als xeParams beim Initialisieren übergeben werden. Alle Parameter können auch einzeln als Objektproperty angesteuert werden

• xeNone Kein Parameter gesetzt

• xeReplaceExistFile Falls die Exportdatei bereits exisitert, kann diese ersetzt werden

• xeCaptionAsHeader Es wird versucht die Titel-Eigenschaft des Tabellenfeldes auszulesen
• xeReadableHeader Der Technische Name wird möglichst in ein lesbaeren Namen Konvertiert
• xeTechnicalHeader Der Technische Name (Feld-Name) wird für den Header verwendet

• xeRunDefaultFormating Nach dem Export wird das Default-Formating angewendet

• xeNotRemoveFormatSheet Das Sheet mit den Formatierungen wird am Schluss nicht entfernt

• xeDefaultParams = xeReplaceExistFile + xeTechnicalHeader + xeRunDefaultFormating

Hier ein Beispiel, auf welche Arten man die Paramter setzen kann

    Dim exp As XlsxExporter
    Set exp = XlsxExporter("v_data", "C:\temp\_v_data.xlsx", , xeReadableHeader + xeReplaceExistFile)
 
    'entspircht
    Set exp = New XlsxExporter
    exp.initialize "v_data", "C:\temp\_v_data.xlsx", , xeReadableHeader + xeReplaceExistFile
 
    'entspircht
    Set exp = XlsxExporter("v_data", "C:\temp\_v_data.xlsx", , xeNone)
    exp.paramReadableHeader = True
    exp.paramReplaceExistFile = True

Initializiert eine Klasseninstanz mit den wichtigsten Paramtern

'/**
' * Initialisiert die Klasse mit allen wichtigen Paramtern
' * @param  String              Quelle
' * @param  String              Export-Pfad
' * @param  AcSpreadSheetType   Excel-Format
' * @param  iParams             Parameters
' */
Public Sub initialize( _
        Optional ByVal iSource As String, _
        Optional ByVal iFilePath As String, _
        Optional ByVal iSpreadSheetType As AcSpreadSheetType = acSpreadsheetTypeExcel12Xml, _
        Optional ByVal iParams As xeParams = xeDefaultParams _
)

Beispiel:

Dim exp As New XlsxExporter
exp.initialize "source", "target.xlsx"

Erstellt und initialisiert ein Objekt dieser Klasse. Diese Methode hat das Attribut Attribute instance.VB_UserMemId = 0. Das bedeutet, wenn an die Klasse ohne Methode initialisiert, wird diese MEthode automatisch aufgerufen

'/**
' * Exportiert die Quelle in eine Excel-Datei und gibt eine Instance dieser Klasse zurück
' * @param  String              Quelle
' * @param  String              Export-Pfad
' * @param  AcSpreadSheetType   Excel-Format
' * @param  iParams             Parameters
' */
Public Function instance( _
        Optional ByVal iSource As String, _
        Optional ByVal iFilePath As String, _
        Optional ByVal iSpreadSheetType As AcSpreadSheetType = acSpreadsheetTypeExcel12Xml, _
        Optional ByVal iParams As xeParams = xeDefaultParams _
) As XlsxExporter

Beispiel:

Dim exp As XlsxExporter
Set exp = XlsxExporter.instance("source", "target.xlsx")
'oder dank Attribute instance.VB_UserMemId = 0
Set exp = XlsxExporter("source", "target.xlsx")

Diese Methode exportiert die Daten in das Excel-Sheet. wenn die Parameter bereits in einer der vorherigen Methoden aufgerufen wurde, können sie hier weggelassen werden.

Bei aktivem paramRunDefaultFormating wird doFormatColumnsByType() automatisch ausgeführt

'/**
' * Exportiert die Quelle in eine Excel-Datei und führt ggf das Standardformting aus
' * @param  String              Quelle
' * @param  String              Export-Pfad
' */
Public Sub export( _
        Optional ByVal iSource As String, _
        Optional ByVal iFilePath As String _
)

Wendet bei aktivem paramRunDefaultFormating und vorhandenem Header die Headerformatierung an, speichert und schliesst die Datei.

Diese Funktion wird bei Class_Terminate() automatisch aufgerufen.

'/**
' * Seichert und schliesst die Datei
' * Diese Methode wird beim Abbauen des Objektes ebenfalls ausgeführt
' * @param  Boolean     Flag ob gespeichert werden soll. True = Cancel = Kein Speichern
' */
Public Sub quit( _
        Optional ByVal iCancel As Boolean = False _
)

Führt eine Formatierung anhand einer Formatvorlage durch.

• Die Quelle ist entweder ein format oder eine Formatdefinition analog zum Property format
• Die Definition des Target entspricht dem Property range.
• Es können mehrere Targets mitKomma getrennt mitgegeben werden

'/**
' * Formatiert Ranges
' * @param  Variant     Ein Range/Formatname der als Formatvorlage dient. Meistens ein Range aus format()
' * @param  Variant     Mehrere Ziele. Die folgenden werden akzeptiert
' *                     NUMMER: Spaltennummer
' *                     STRING: Spalte mit dem Feldnamen iTarget oder Excel-Range-String ("A1:B13")
' *                     RANGE:  Der Range wird entsprechend formatiert
' */
Public Sub doFormat( _
    ByRef iFormat As Variant, _
    ParamArray iTargets() As Variant _
)

exp.doFormat "mein_formatname", "1:1"
exp.doFormat .format("mein_formatname"), .range("1:1")
exp.doFormat "mein_formatname", "1:1", "A3", .myRange

Wendet die defaultFormat auf das ganze Sheet an.

Wird bei aktivem paramRunDefaultFormating am Ende der Funktion export() automatisch ausgeführt

'/**
' * Formatiert das ganze Sheet mit der Standartformatierung
' */
Public Sub doFormatDefault()

Formatiert Spalten Anhand ihres Feldtype der Quelle. Sie kann auf einzelne Spalten oder auf das ganez Sheet angewendet werden.

Wird bei aktivem paramRunDefaultFormating am Ende der Funktion export() automatisch ausgeführt

'/**
' * formatiert Spalten anhand der Spaltentypen
' * @param  Variant     Range-Definition. Wenn diese weggelassen wird, werden alleSpalten nach Spaltentypen formatiert
' */
Public Sub doFormatColumnsByType( _
        Optional ByRef iRangeDef As Variant = Null _
)

Passt die Spaltenbreiten den Daten an

Wird bei ativem paramRunDefaultFormating im quit() automatisch ausgeführt

'/**
' passt die Spaltenbreite an. Wird bei paramRunDefaultFormating=true automatisch durchgeführt
' */
Public Sub autoFit()

Wenn man Anpassungen an dem defaultFormat vornimmt, kann man mit dieser Methode das neue Standardformat auf die restlichen Typenformate anwenden.

'/**
' * Berechnet die Standardformate neu, basierend auf dem defaultFormat
' */
Public Sub requeryDefaultFormats()

Das Format-Property gibt ein Excel.Range zurück. Diesen kann man dann nach belieben Formatieren und dient für die Methode doFormat() als Vorlage.
Formate können über einen Namen oder einen DAO.DataTypeEnum definiert werden.

• Die Typenformate werden in der Methode doFormatColumnsByType() anhand des Feldtypes der Datenbank auf die Spalten angewendet.
• Es können auch freie Formate mit eigenen Namen verwaltet werden
• In der Internen Methode setDefaultFormats() sind einige Formate vordefiniert.

'/**
' * Ein Excel.Range,der als FOrmatvorlage dient
' * @param  Variant     Name oder dao.DataTypeEnum um das Format zu definieren
' * @param  Variant     Format/Range oder FormatName der als Formatvorlage dient
' * @param  Boolean     Bestehende Formateinstellungen verwerfen
' */
Public Property Get format( _
        ByVal iNameOrType As Variant, _
        Optional ByRef iPattern As Variant = C_DEFAULT_FORMAT_NAME, _
        Optional ByVal iOverwrite As Boolean = False _
) As Excel.range

Beispiel

'Ausführlecher Weg ein benanntes Format zu erstellen & definieren
Dim frmt As Excel.Range
Set frmt = exp.format("Mein format")
frmt.font.bold = true
frmt.font.italic = true
 
'Vereinfachte Anwendung
exp.format("Mein format").font.bold = true
exp.format("Mein format").font.italic = true

Direktzugriff auf die Formatvorlage für das Standardformat über das ganze Sheet.

Diese Formatierungen sollte vor allen anderen Formatierungen angepasst werden, da sie die Grundlage für alle weiteren Formatierungen ist

Nach Anpassungen dieses Formats unbedingt die Methode requeryDefaultFormats() aufrufen

'/**
' * Direktzugirff auf das Standardformat
' */
Public Property Get defaultFormat() As Excel.range

exp.defaultFormat.font.size=10
exp.requeryDefaultFormats

Direkter Zugriff auf das Format des Headers

'/**
' * Direktzugirff auf die Headerformatierung
' */
Public Property Get headerFormat() As Excel.range

exp.headerFormat.font.bold = true

Gibt einen Excel.Range des DataSheets zurück.

'/**
' * gibt ein Range des DataSheets zurück
' * @param  Variant     Spaltennummer/Spaltenname/Range/Cell2 & Cell2/Excel-Range-String ("A1", "A1:C3" etc)
' * @param  Variant     Spaltennummer/Spaltenname/Range/Cell2 & Cell2/Excel-Range-String ("A1", "A1:C3" etc)
' * @return Range
' */
Public Property Get range( _
    ByRef iRangeDef1 As Variant, _
    Optional ByRef iRangeDef2 As Variant = Null _
) As Excel.range

Dim rng As Excel.Range
Set rng = exp.range(1)			'Spalte 1
Set rng = exp.range("Mein Feldname")	'Spalte die dem Feld [Mein Feldname] der Quelle entspricht
Set rng = exp.range("A3")		'Zelle A3
Set rng = exp.range("1:1")		'Erste Zeile
Set rng = exp.range("A3:B4")		'Zellen A3 bis B4
Set rng = exp.range(myRange)		'Enspricht dem Range myRange
Set rng = exp.range("A3", "B4")		'Zellen A3 bis B4
Set rng = exp.Range(myRange, "Z:Z")	'Alles von myRange bis zur SpalteZ

Exportiert eine Tabelle mit Standardformatierung exportonly1.xlsx

XlsxExporter("my_table", "c:\temp\_exportOnly1.xlsx").export

Exportiert eine Tabelle ohne Standardformatierung exportonly2.xlsx

XlsxExporter("my_table", "c:\temp\_exportOnly2.xlsx", , xeNone).export

Eigene Formate erstellen und diese auf den export anwenden. exportformated1.xlsx

    With XlsxExporter("my_table", "c:\temp\_exportFormated1.xlsx")
        'Format definieren. Nur mit Namen
        .format("BOLD").Font.Bold = True     'Neuer benanntes Format erstellen
        'Format als eigene Variable
        Dim frmtGood As Excel.range
        Set frmtGood = .format("GOOD")
        frmtGood.Style = "Good"              'Noch eines mit einem Excel-Style
        frmtGood.Font.Bold = True            'und bei demselben auch noch Bold einstellen
        'Datei exportieren
        .export
        'Formate anwednen
        .doFormat "BOLD", "A:A"              'Bold auf die erste Spalte anwenden
        .doFormat frmtGood, "B:B", .range("C2", "D4")   'Good auf Spalte B und auf den Range von C2 bis D4 anwednen
    End With

Bei diesem Beispiel wird die Standardformatierung des Exporters berschrieben. Zudem werden die Parameter über Quelle und Ziel erst beim export() mitgegeben. exportformated2.xlsx

    With XlsxExporter()         'Achtung! Die Klammern müssen gesetzt sein, damit die Instanzierung sauber funktioniert
        'property setzen.
        'Per default ist xeReplaceExistFile + xeTechnicalHeader + xeRunDefaultFormating gesetzt
        .paramCaptionAsHeader = True
        'Standardformat anpassen
        With .defaultFormat
            .Font.size = 8
            .Font.Name = "Courier New"
        End With
        'Standardformat auf alle typenformate anwenden
        .requeryDefaultFormats
        'exportieren. Die Quelle und das Zeil können auch beim export() metgegeben werden
        .export "my_table", "c:\temp\_exportFormated2.xlsx"
    End With

In diesem Beispiel wird dieFormatierung des Headers angepasst. Zudem greifen wir über einen Feldnamen der Access-Tabelle auf die Spalte im Excel zu. exportformated3.xlsx

     With XlsxExporter("my_table", "c:\temp\_exportFormated3.xlsx")
        'property setzen.
        'Per default ist xeReplaceExistFile + xeTechnicalHeader + xeRunDefaultFormating gesetzt
        .paramCaptionAsHeader = True
 
        'Typenformat definieren/ergänzen/überscheiben
        'Die Typenformatierungen werden in der Methode export() bei
        'aktivem Flag xeRunDefaultFormating automatisch vorgenommen
        .format(dbDate).NumberFormat = "yyyy-mm-dd"
 
        'Das Standard-Headerformat ändern
        'Der Header wird beim schliessen und aktivem xeRunDefaultFormating formatiert
        .headerFormat.Font.size = 12
        .headerFormat.Font.Color = rgbGreen
 
        .export
        '"FX_RATES" ist ein vordefiniertes Format (siehe private Sub setDefaultFormats())
        '"F_RATE" ist ein Spaltenname. Ich kann über den Namen direkt auf diese Spalte zugreiffen
        .doFormat "FX_RATE", "F_RATES"
 
    End With

Es macht ja wenig Sinn, für jede Spalte extra eine Formatierung anzulegen. Deshalb hier mal ein Beispiel in dem es sich lohnnt. Eine View mit mehreren Spalten die gleich formtiertwerden müssen.
v_data.xlsx
für einfachere Fälle siehe auch Direkte Formatierung

    With XlsxExporter("v_data", "C:\temp\_v_data.xlsx")
        .format("PERCENT").NumberFormat = "0.0000%"     'Prozentzahl mit 4 Nachkomma
        .format("THOUSEND").NumberFormat = "#'##0'"     'Nur ab Tausend anzeigen  15'000 -> 15'
        .export
        .doFormat "FX_RATE", "fx_rate"                  'fx_rate mit der vordefinierten FX_RATE-Format formatieren
        .doFormat "PERCENT", "PERC_CHF", "PERC_PC"      'Prozentformatierung auf alle Prozentwerte anwenden
        'Viele Felder mit der Spezialformatierung formatieren
        .doFormat "THOUSEND", "PRICE_CHF_NOW", "PRICE_CHF_Yesterday", "DIFF_CHF", "PRICE_PC_NOW", "PRICE_PC_YESTERDAY", "DIFF_PC"
    End With

Die obigen Beispiele sind natürlich nur nützlich, wenn an ein Format auf mehrere Spalten anwenden will (siehe Sinnvolles Beispiel für die vordefinierten Formate.
Für einfacher Sachen kann man auch direkt die Range-Formate mitgeben. exportformated4.xlsx

    With XlsxExporter("my_table", "c:\temp\_exportFormated4.xlsx", acSpreadsheetTypeExcel12Xml, xeReplaceExistFile)
        .export
        'Spalte 1 direkt Formatieren
        .range(1).Font.size = 13
        'Das Feld f_bool aus der Tabelle
        .range("f_bool").Font.Italic = True
        'Und ein beliebiger Range. In dem Fall Zeile 1 mit dem Header
        .range("1:1").Font.Bold = True
    End With

xlsxexporter.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "XlsxExporter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'-------------------------------------------------------------------------------
'File         : XlsxExporter.cls
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/access/xlsxexporter
'Environment  : VBA 2007+
'Required     : Referenz auf 'MicrosoftExcel XY ObjectLibrary'
'Version      : 2.0.0
'Name         : XlsxExporter
'Author       : Stefan Erb (ERS)
'History      : 27.01.2015 - ERS - Creation
'               28.01.2015 - ERS - Property Get sheet auf Public gewechselt
'               05.02.2015 - ERS - Mächtig erweitert. Viele neue Methoden
'-------------------------------------------------------------------------------
 
'-------------------------------------------------------------------------------
' Ablauf
' 1) Objekt erstellen
'           Set xExp = XlsxExporter("my_table", "c:\my_path\my_file.xlsx")
' 2) Paramters setzen, falls man das nicht bereits in 1) gemacht hat
'           xExp.paramReadableHeader = true
' 3) Standardformat anpassen
'           xexp.defaultFormat.Font.Size = 10
' 4) Standardformat auf alle vdefinierten Formate anpassen
'           xExp.requeryDefaultFormats
' 5) Dateitypenformate anpassen
'           xExp.format(dbLong).Font.Italic = true
' 6) Weitere Formate definieren
'           xExp.format("MEIN_FORMAT_1").foont.bold = true
' 7) Exportieredie Daten
'           xExp.export
' 8) Formatierungen anweden
'           xExp.doFormatColumnsByType
'           xExp.doFormat "MEIN_FORMAT_1", "C:C"
' 9) Objekt abbauen
'           Set xExp = Nothing
'       oder
'           xExp.quit
'-------------------------------------------------------------------------------
Option Explicit
 
'-------------------------------------------------------------------------------
' -- Public Members
'-------------------------------------------------------------------------------
Public Enum xeParams
    xeNone = 0                          'Kein Parameter
'Datei-Handler
    xeReplaceExistFile = 2 ^ 0          'Falls die Exportdatei bereits exisitert, kann diese ersetzt werden
'Heder-Settings
    xeCaptionAsHeader = 2 ^ 1           'Es wird versucht die Titel-Eigenschaft des Tabellenfeldes auszulesen
    xeReadableHeader = 2 ^ 2            'Der Technische Name wird möglichst in ein lesbaeren Namen Konvertiert
    xeTechnicalHeader = 2 ^ 3           'Der Technische Name (Feld-Name) wird für den Header verwendet
'Formatierung
    xeRunDefaultFormating = 2 ^ 4       'Nach dem Export wird das Default-Formating angewendet
'WeitereSettings
    xeNotRemoveFormatSheet = 2 ^ 5      'Das Sheet mit den Formatierungen wird am Schluss nicht entfernt
'Standard, wenn nichts angegeben wird
    xeDefaultParams = xeReplaceExistFile + xeTechnicalHeader + xeRunDefaultFormating
End Enum
 
'-------------------------------------------------------------------------------
' -- Public Members
'-------------------------------------------------------------------------------
Private Const C_FORMAT_SHEET_NAME = "FORMATS"
Private Const C_HEADER_FORMAT_NAME = "HEADER"
Private Const C_DEFAULT_FORMAT_NAME = "DEFAULT"
 
 
Private Const C_ERR_CANCELLED = vbObjectError + 1       'Operation cancelled by user
Private Const C_ERR_NOT_DETETD = vbObjectError + 2      'Unable to delete file
Private Const C_ERR_NOT_EXPORTED = vbObjectError + 3
 
Private pFilePath           As String
Private pSource             As String
Private pParams             As xeParams
Private pSpreadSheetType    As AcSpreadSheetType
Private pDataExported       As Boolean
Private pAllreadyQuit       As Boolean
 
'-------------------------------------------------------------------------------
' -- Private Standards
'-------------------------------------------------------------------------------
 
'/**
' * Standardformatierung definieren
' * Diese können beliebig geändert werden
' */
Private Sub setDefaultFormats(Optional ByRef iPattern As Variant = C_DEFAULT_FORMAT_NAME, Optional ByVal iOverwrite As Boolean = False)
    Static defFormatsSetted As Boolean
    If defFormatsSetted And Not iOverwrite Then Exit Sub
 
    'Standardformat
    '-------------------------------------
    'Dieses muss als erstes definiert werden, da es als Grundlage für alle weiteren Definitionen gilt
    If Not formats.exists(C_DEFAULT_FORMAT_NAME) Then defaultFormat.Font.size = 9
 
    'Headerzeile
    '-------------------------------------
    format(C_HEADER_FORMAT_NAME, iPattern, True).Font.Bold = True
    With headerFormat.Interior
        .pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
 
    'Typenformate
    '-------------------------------------
    'Datumsfomratierungungen
    format(dbDate, iPattern, True).NumberFormat = "dd.mm.yyyy"
    format(dbTimeStamp, iPattern, True).NumberFormat = "dd.mm.yyyy hh:mm:ss"
    format(dbTime, iPattern, True).NumberFormat = "hh:mm:ss"
 
 
    'Zahlenformatierungen
    format(dbDouble, iPattern, True).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
    format(dbLong, iPattern, True).NumberFormat = "0"
    format(dbInteger, iPattern, True).NumberFormat = "0"
 
    'Weitere benannte Formatierungen
    '-------------------------------------
    'Zahlen
    format("FX_RATES", iPattern, True).NumberFormat = "0.00000"
    format("PERCENT", iPattern, True).NumberFormat = "0.00%"
 
    defFormatsSetted = True
End Sub
 
'-------------------------------------------------------------------------------
' -- Public Methodes
'-------------------------------------------------------------------------------
'/**
' * Exportiert die Quelle in eine Excel-Datei und gibt eine Instance dieser Klasse zurück
' * @param  String              Quelle
' * @param  String              Export-Pfad
' * @param  AcSpreadSheetType   Excel-Format
' * @param  iParams             Parameters
' */
Public Function instance( _
        Optional ByVal iSource As String, _
        Optional ByVal iFilePath As String, _
        Optional ByVal iSpreadSheetType As AcSpreadSheetType = acSpreadsheetTypeExcel12Xml, _
        Optional ByVal iParams As xeParams = xeDefaultParams _
) As XlsxExporter
Attribute instance.VB_UserMemId = 0
'Attribute instance.VB_UserMemId = 0
    Set instance = New XlsxExporter
    instance.initialize iSource, iFilePath, iSpreadSheetType, iParams
End Function
 
'/**
' * Initialisiert die Klasse mit allen wichtigen Paramtern
' * @param  String              Quelle
' * @param  String              Export-Pfad
' * @param  AcSpreadSheetType   Excel-Format
' * @param  iParams             Parameters
' */
Public Sub initialize( _
        Optional ByVal iSource As String, _
        Optional ByVal iFilePath As String, _
        Optional ByVal iSpreadSheetType As AcSpreadSheetType = acSpreadsheetTypeExcel12Xml, _
        Optional ByVal iParams As xeParams = xeDefaultParams _
)
    filePath = iFilePath
    source = iSource
    pParams = iParams
    spreadSheetType = iSpreadSheetType
    If paramRunDefaultFormating Then setDefaultFormats
    pAllreadyQuit = False
End Sub
 
'/**
' * Exportiert die Quelle in eine Excel-Datei und führt ggf das Standardformting aus
' * @param  String              Quelle
' * @param  String              Export-Pfad
' */
Public Sub export( _
        Optional ByVal iSource As String, _
        Optional ByVal iFilePath As String _
)
    If Not iSource = Empty Then source = iSource
    If Not iFilePath = Empty Then filePath = iFilePath
    'in eine temporäre Date exportieren
    DoCmd.TransferSpreadsheet acExport, spreadSheetType, source, tempExportFilePath, hasHeader
 
    'Temporäres Workbook/sheet öffnen
    Dim wbTemp As Excel.Workbook:   Set wbTemp = xlsx.Workbooks.Open(tempExportFilePath)
    Dim wsTemp As Excel.Worksheet:  Set wsTemp = wbTemp.Worksheets(source)
    'Export in das aktuelle Worksheet kopieren
    wsTemp.Copy before:=wsFomats
    dataExported = True
    'Temporäres WOrkbook schliessen/löschen
    wbTemp.Close
    cFso.DeleteFile tempExportFilePath
 
    'Standarddormatierungen durchführen
    'ohne hEaderformatierung. diese wird bei quit() ausgeführt
    If paramRunDefaultFormating Then
        doFormatDefault
        doFormatColumnsByType
    End If
End Sub
 
'/**
' * gibt die Spaltennummer zu einem Feldnamen zurück
' * @param  String      Spaltenname
' * @return Long        Spaltennummer / Null falls die Spalte nicht gefunden wurde
' */
Public Function getColNrByName(ByVal iFieldName As String) As Long
    If Not dataExported Then Err.Raise C_ERR_NOT_EXPORTED, "XlsxExporter.getColNrByName", "Data not exported. First run export()"
    If index.exists(iFieldName) Then
        getColNrByName = index(iFieldName)
    Else
        getColNrByName = Null
    End If
End Function
 
'/**
' * Seichert und schliesst die Datei
' * Diese Methode wird beim Abbauen des Objektes ebenfalls ausgeführt
' * @param  Boolean     Flag ob gespeichert werden soll. True = Cancel = Kein Speichern
' */
Public Sub quit( _
        Optional ByVal iCancel As Boolean = False _
)
    If iCancel Or pAllreadyQuit Then GoTo Exit_Handler
    If Not dataExported Then Err.Raise C_ERR_NOT_EXPORTED, "XlsxExporter.quit", "Data not exported. First run export()"
 
     'Datei ersetzen
    If cFso.FileExists(filePath) Then
        If paramReplaceExistFile Then
            cFso.DeleteFile (filePath)
        ElseIf MsgBox("File " & filePath & "allready exists." & vbCrLf & "Replace the File?", vbOKCancel + vbDefaultButton1 + vbQuestion) = vbOK Then
            cFso.DeleteFile (filePath)
        Else
            Err.Raise C_ERR_CANCELLED, "XlsxExporter.export", "Operation cancelled by user"
        End If
        If cFso.FileExists(filePath) Then Err.Raise C_ERR_NOT_DETETD, "XlsxExporter.export", "Unable to delete file " & filePath
    End If
 
    'Header formatieren
    If hasHeader And paramRunDefaultFormating Then doFormatHeader
    'Autofit ausführen (Spaltenbreite anpassen)
    If paramRunDefaultFormating Then autoFit
    'Format-Sheet entfernen
    If Not paramNotRemoveFormatSheet Then
        xlsx.DisplayAlerts = False
        wsFomats.delete
        xlsx.DisplayAlerts = True
    End If
 
    'Datensheet selektionieren und alles speichern
    wsData.Select
    wb.SaveAs filePath
 
Exit_Handler:
    wb.Close False
    xlsx.quit
    pAllreadyQuit = True
End Sub
 
'/**
' * Formatiert Ranges
' * @param  Variant     Ein Range/Formatname der als Formatvorlage dient. Meistens ein Range aus format()
' * @param  Variant     Mehrere Ziele. Die folgenden werden akzeptiert
' *                     NUMMER: Spaltennummer
' *                     STRING: Spalte mit dem Feldnamen iTarget oder Excel-Range-String ("A1:B13")
' *                     RANGE:  Der Range wird entsprechend formatiert
' */
Public Sub doFormat( _
    ByRef iFormat As Variant, _
    ParamArray iTargets() As Variant _
)
    If Not dataExported Then Err.Raise C_ERR_NOT_EXPORTED, "XlsxExporter.doFormat", "Data not exported. First run export()"
    If TypeName(iFormat) = "Range" Then
        iFormat.Copy
    Else
        format(iFormat).Copy
    End If
    Dim target As Variant: For Each target In iTargets
        range(target).PasteSpecial xlPasteFormats
    Next
    xlsx.CutCopyMode = False
End Sub
 
'/**
' * Formatiert das ganze Sheet mit der Standartformatierung
' */
Public Sub doFormatDefault()
    If Not dataExported Then Err.Raise C_ERR_NOT_EXPORTED, "XlsxExporter.doFormatDefault", "Data not exported. First run export()"
    doFormat defaultFormat, wsData.Cells
End Sub
 
'/**
' * Formatiert die Headerzeile, sofern ein Header vorhanden ist
' * Wird bei paramRunDefaultFormating = true amEnde automatisch ausgeführt
' */
Public Sub doFormatHeader()
    If Not dataExported Then Err.Raise C_ERR_NOT_EXPORTED, "XlsxExporter.doFormatHeader", "Data not exported. First run export()"
    If hasHeader Then
        Dim cell As range: For Each cell In range("1:1").Cells
            If cell.value = Empty Then Exit For
            If paramCaptionAsHeader And Not IsNull(fields.item(cell.Column)("CAPTION")) Then
                cell.value = fields.item(cell.Column)("CAPTION")
            ElseIf pParams And xeReadableHeader Then
                cell.value = readableName(cell.value)
            End If
        Next
        If paramRunDefaultFormating Then doFormat headerFormat, range("A1", wsData.Cells(1, fields.count))
    End If
End Sub
 
'/**
' * formatiert Spalten anhand der Spaltentypen
' * @param  Variant     Range-Definition. Wenn diese weggelassen wird, werden alleSpalten nach Spaltentypen formatiert
' */
Public Sub doFormatColumnsByType( _
        Optional ByRef iRangeDef As Variant = Null _
)
    If Not dataExported Then Err.Raise C_ERR_NOT_EXPORTED, "XlsxExporter.doFormatColumnsByType", "Data not exported. First run export()"
 
    Dim rng As Excel.range
    If IsNull(iRangeDef) Then
        Set rng = range("A:" & xlsColLetter(fields.count))
    Else
        Set rng = range(iRangeDef)
    End If
    Dim i As Long: For i = rng.Column To (rng.Column + rng.Columns.count - 1)
        Dim type1 As DAO.DataTypeEnum: type1 = fields.item(i)("TYPE")
        If formats.exists(type1) Then doFormat format(type1), fields.item(i)("COL_NR")
    Next i
End Sub
 
'/**
' passt die Spaltenbreite an. Wird bei paramRunDefaultFormating=true automatisch durchgeführt
' */
Public Sub autoFit()
    wsData.Cells.EntireColumn.autoFit
End Sub
 
 
'/**
' * Berechnet die Stanrdformate neu, basierend auf dem defaultFormat
' */
Public Sub requeryDefaultFormats()
    setDefaultFormats C_DEFAULT_FORMAT_NAME, True
End Sub
 
'-------------------------------------------------------------------------------
' -- Public Properties
'-------------------------------------------------------------------------------
 
'/**
' * gibt ein Range des DataSheets zurück
' * @param  Variant     Spaltennummer/Spaltenname/Range/Cell2 & Cell2/Excel-Range-String ("A1", "A1:C3" etc)
' * @param  Variant     Spaltennummer/Spaltenname/Range/Cell2 & Cell2/Excel-Range-String ("A1", "A1:C3" etc)
' * @return Range
' */
Public Property Get range( _
    ByRef iRangeDef1 As Variant, _
    Optional ByRef iRangeDef2 As Variant = Null _
) As Excel.range
    If Not dataExported Then Err.Raise C_ERR_NOT_EXPORTED, "XlsxExporter.getRange", "Data not exported. First run export()"
    Dim rng1, rng2 As Excel.range
 
    'Cell2 ermitteln
    If Not IsNull(iRangeDef2) Then Set rng2 = range(iRangeDef2)
 
    Select Case TypeName(iRangeDef1)
        Case "Long", "Integer":     Set range = wsData.Columns(iRangeDef1)
        Case "Range":               Set range = iRangeDef1
        Case "String":
                                    If index.exists(UCase(iRangeDef1)) Then
                                        Set range = wsData.Columns(index(UCase(iRangeDef1)))
                                    Else
                                        Set range = wsData.range(iRangeDef1)
                                    End If
        Case Else:                  Err.Raise 13, "XlsxExporter.getRange()"     '13  Type mismatch
    End Select
    'Falls Cell2 vorhanden ist, range neu definieren
    If Not rng2 Is Nothing Then Set range = wsData.range(range, rng2)
End Property
 
'/**
' * Quelle
' */
Public Property Get source() As String
    source = pSource
End Property
Public Property Let source(ByVal iSource As String)
    pSource = iSource
    readSourceInformations
End Property
 
'/**
' * Export-Pfad
' */
Public Property Get filePath() As String
    filePath = pFilePath
End Property
Public Property Let filePath(ByVal iFilePath As String)
    pFilePath = iFilePath
End Property
 
'/**
' * Excel-Format
' */
Public Property Get spreadSheetType() As AcSpreadSheetType
    spreadSheetType = pSpreadSheetType
End Property
Public Property Let spreadSheetType(ByVal iSpreadSheetType As AcSpreadSheetType)
    pSpreadSheetType = iSpreadSheetType
End Property
 
 
'/**
' * Flag, ob die Daten bereits exportiert wurden
' */
Public Property Get dataExported() As Boolean
    dataExported = pDataExported
End Property
Private Property Let dataExported(ByVal iExported As Boolean)
    pDataExported = iExported
End Property
 
'/**
' * Das Worksheet mit den exportierten Daten
' */
Public Property Get wsData() As Excel.Worksheet
    Static ws As Excel.Worksheet
    If Not dataExported Then Err.Raise C_ERR_NOT_EXPORTED, "XlsxExporter.doFormat", "Data not exported. First run export()"
    If ws Is Nothing Then Set ws = wb.Worksheets(source)
    Set wsData = ws
End Property
 
'/**
' * Das Excelsheet hat eine Headerzeile
' */
Public Property Get hasHeader() As Boolean
    hasHeader = paramCaptionAsHeader Or paramReadableHeader Or paramTechnicalHeader
End Property
 
'/**
' *  Falls die Exportdatei bereits exisitert, kann diese ersetzt werden
'*/
Public Property Get paramReplaceExistFile() As Boolean
    paramReplaceExistFile = (pParams And xeReplaceExistFile) = xeReplaceExistFile
End Property
Public Property Let paramReplaceExistFile(ByVal iParam As Boolean)
    If Not paramReplaceExistFile = iParam Then pParams = pParams + IIf(iParam, 1, -1) * xeReplaceExistFile
End Property
 
'/**
' *  Es wird versucht die Titel-Eigenschaft des Tabellenfeldes auszulesen
'*/
Public Property Get paramCaptionAsHeader() As Boolean
    paramCaptionAsHeader = (pParams And xeCaptionAsHeader) = xeCaptionAsHeader
End Property
Public Property Let paramCaptionAsHeader(ByVal iParam As Boolean)
    If Not paramCaptionAsHeader = iParam Then pParams = pParams + IIf(iParam, 1, -1) * xeCaptionAsHeader
End Property
 
'/**
' *  Der Technische Name wird möglichst in ein lesbaeren Namen Konvertiert
'*/
Public Property Get paramReadableHeader() As Boolean
    paramReadableHeader = (pParams And xeReadableHeader) = xeReadableHeader
End Property
Public Property Let paramReadableHeader(ByVal iParam As Boolean)
    If Not paramReadableHeader = iParam Then pParams = pParams + IIf(iParam, 1, -1) * xeReadableHeader
End Property
 
'/**
' *  'Der Technische Name (Feld-Name) wird für den Header verwendet
'*/
Public Property Get paramTechnicalHeader() As Boolean
    paramTechnicalHeader = (pParams And xeTechnicalHeader) = xeTechnicalHeader
End Property
Public Property Let paramTechnicalHeader(ByVal iParam As Boolean)
    If Not paramTechnicalHeader = iParam Then pParams = pParams + IIf(iParam, 1, -1) * xeTechnicalHeader
End Property
 
'/**
' *  Nach dem Export wird das Default-Formating angewendet
'*/
Public Property Get paramRunDefaultFormating() As Boolean
    paramRunDefaultFormating = (pParams And xeRunDefaultFormating) = xeRunDefaultFormating
End Property
Public Property Let paramRunDefaultFormating(ByVal iParam As Boolean)
    If iParam Then setDefaultFormats
    If Not paramRunDefaultFormating = iParam Then pParams = pParams + IIf(iParam, 1, -1) * xeRunDefaultFormating
End Property
 
'/**
' *  'Das Sheet mit den Formatierungen wird am Schluss nicht entfernt
'*/
Public Property Get paramNotRemoveFormatSheet() As Boolean
    paramNotRemoveFormatSheet = (pParams And xeNotRemoveFormatSheet) = xeNotRemoveFormatSheet
End Property
Public Property Let paramNotRemoveFormatSheet(ByVal iParam As Boolean)
    If Not paramNotRemoveFormatSheet = iParam Then pParams = pParams + IIf(iParam, 1, -1) * xeNotRemoveFormatSheet
End Property
 
'/**
' * Ein Excel.Range,der als FOrmatvorlage dient
' * @param  Variant     Name oder dao.DataTypeEnum um das Format zu definieren
' * @param  Variant     Format/Range oder FormatName der als Formatvorlage dient
' * @param  Boolean     Bestehende Formateinstellungen verwerfen
' */
Public Property Get format( _
        ByVal iNameOrType As Variant, _
        Optional ByRef iPattern As Variant = C_DEFAULT_FORMAT_NAME, _
        Optional ByVal iOverwrite As Boolean = False _
) As Excel.range
    Dim pattern As Excel.range
    If Not iNameOrType = C_DEFAULT_FORMAT_NAME Then
        Set pattern = IIf(TypeName(iPattern) = "Range", iPattern, format(iPattern))
    End If
 
    If formats.exists(iNameOrType) And iOverwrite Then formats.remove iNameOrType
 
    If Not formats.exists(iNameOrType) Then
        If IsNumeric(iNameOrType) Then
            formats.add iNameOrType, wsFomats.Cells(1, iNameOrType)
        Else
            formats.add iNameOrType, wsFomats.Cells(2, formats.count + 1)
        End If
        If Not iNameOrType = C_DEFAULT_FORMAT_NAME Then
            pattern.Copy
            formats(iNameOrType).PasteSpecial xlPasteFormats
        End If
    End If
    formats(iNameOrType).value = CStr(iNameOrType)
    Set format = formats(iNameOrType)
End Property
 
'/**
' * Direktzugirff auf das Standardformat
' */
Public Property Get defaultFormat() As Excel.range
    Set defaultFormat = format(C_DEFAULT_FORMAT_NAME)
End Property
 
'/**
' * Direktzugirff auf die Headerformatierung
' */
Public Property Get headerFormat() As Excel.range
    Set headerFormat = format(C_HEADER_FORMAT_NAME)
End Property
 
'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Erstellt aus einemTechnischen Namen etwas möglichst lesbares
' * @param  String
' * @return String
' */
Private Function readableName(ByVal iTechName As String) As String
    Dim words() As String
    If Not rxWords.Test(iTechName) Then
        ReDim words(0): words(0) = Replace(iTechName, "_", " ")
    Else
        Dim mc As Object: Set mc = rxWords.Execute(iTechName)
        ReDim words(mc.count)
        Dim idx As Integer: For idx = 0 To mc.count - 1
            words(idx) = mc(idx).value
        Next idx
    End If
    readableName = StrConv(Join(words, " "), vbProperCase)
End Function
 
'/**
' * Gibt den Buchstaben-Key für eine ExcelSpalte anhand einer Spaltennummer aus (Beginnend mit 1)
' *
' * spaltencode = clsColLetter(spaltennummer)
' *
' * @param  Long    Index der Spalte
' * @return String  Spaltenkey
' */
Private Function xlsColLetter(ByVal iColumnNumber As Long) As String
    Const C_ASCII_DELTA = 64
    Dim nr As Long: nr = iColumnNumber
    Do
        Dim rest As Integer: rest = nr Mod 26
        If rest = 0 Then rest = 26
        xlsColLetter = Chr(rest + C_ASCII_DELTA) & xlsColLetter
        nr = Fix((nr - 1) / 26)
    Loop While nr > 0
End Function
 
'-------------------------------------------------------------------------------
' -- Private Properties
'-------------------------------------------------------------------------------
 
'/**
' * DieExcel-Instance
' */
Private Property Get xlsx() As Excel.application
    Static pXlsx As Excel.application
    If pXlsx Is Nothing Then Set pXlsx = New Excel.application
    Set xlsx = pXlsx
End Property
 
 
'/**
' * Das Workbook mitden Exportierten Daten
' */
Private Property Get wb() As Excel.Workbook
    Static pWb As Excel.Workbook
    If pWb Is Nothing Then Set pWb = xlsx.Workbooks.add
    Set wb = pWb
End Property
 
'/**
' * Temporäres Sheet um die Formate zu speichern
' * Erste Zeile: Spalte(DAO.DataTypeEnum) beinhaltet das entsprechende Format
' */
Private Property Get wsFomats() As Excel.Worksheet
    Static ws As Excel.Worksheet
On Error GoTo Err_Handler
    If ws Is Nothing Then Set ws = wb.Worksheets(C_FORMAT_SHEET_NAME)
 
Exit_Handler:
    Set wsFomats = ws
    Exit Property
 
Err_Handler:
    If Err.Number = 9 Then
        Set ws = wb.Worksheets.add(): ws.Name = C_FORMAT_SHEET_NAME
        Resume Exit_Handler
    Else
        Err.Raise Err.Number, Err.source, Err.Description, Err.HelpFile, Err.HelpContext
    End If
End Property
 
 
'/**
' * RegExpzur Wörtererkennung
' */
Private Property Get rxWords() As Object
    Static pRx As Object
    If pRx Is Nothing Then Set pRx = cRx("/(?![\s_])(?:[A-Z]?[^A-Z\s_]+)/g")
    Set rxWords = pRx
End Property
 
'/**
' * Dictionary mit den Feldinformationen
' */
Private Property Get fields(Optional ByVal iRequery As Boolean) As Object
    Static pDict As Object
    If pDict Is Nothing Then Set pDict = CreateObject("scripting.Dictionary")
    Set fields = pDict
End Property
 
Private Sub readSourceInformations()
    index.RemoveAll
    fields.RemoveAll
    Dim pRs As DAO.Recordset: Set pRs = CurrentDb.OpenRecordset(source)
    Dim fld As DAO.Field: For Each fld In pRs.fields
        Dim colLetter As String: colLetter = xlsColLetter(fld.OrdinalPosition + 1)
        Dim colNr As Long: colNr = fld.OrdinalPosition + 1
        Dim fldDef As Object: Set fldDef = CreateObject("scripting.Dictionary")
        With fldDef
            .add "NAME", fld.Name
            .add "CAPTION", getProperty(fld, "CAPTION")
            .add "COL_NR", colNr
            .add "COL_LETTER", colLetter
            .add "TYPE", fld.Type
        End With
        fields.add colNr, fldDef
        index.add UCase(fld.Name), colNr
    Next
    If fields.exists("TYPE") Then fields.remove ("TYPE")
 
End Sub
 
'/**
' * Index der Felder
' * Dictionary(Feldname) = ColNumber
' */
Private Property Get index() As Object
    Static pDict As Object
    If pDict Is Nothing Then Set pDict = CreateObject("scripting.Dictionary")
    Set index = pDict
End Property
 
'/**
' * Die Formatsammlung
' */
Private Property Get formats() As Object
    Static pDict As Object
    If pDict Is Nothing Then Set pDict = CreateObject("scripting.Dictionary")
    Set formats = pDict
End Property
 
Private Property Get tempExportFilePath() As String
    Static pPath As String
    If pPath = Empty Then pPath = cFso.BuildPath(cFso.GetParentFolderName(filePath), cFso.GetBaseName(filePath) & "_" & VBA.format(Now, "YYYYMMDD_HHNNSS") & "." & cFso.GetExtensionName(filePath))
    tempExportFilePath = pPath
End Property
 
'-------------------------------------------------------------------------------
' -- Private Event
'-------------------------------------------------------------------------------
Private Sub Class_Initialize()
        spreadSheetType = acSpreadsheetTypeExcel12Xml
        pParams = xeDefaultParams
End Sub
 
Private Sub Class_Terminate()
    quit
End Sub
 
'-------------------------------------------------------------------------------
' -- Private Libraries
'-------------------------------------------------------------------------------
 
'/**
' * Gibt ein FileSystemObject zurück
' * @return FileSystemObject
' */
Private Property Get cFso() As Object
    Static cachedObj As Object
    If cachedObj Is Nothing Then Set cachedObj = CreateObject("Scripting.FileSystemObject")
    Set cFso = cachedObj
End Property
 
'/**
' * Dieverse Objekte in Access besitzen Properties. DIese sind aber nicht immer initialisiert
' * Mit dieser Funktion verscuht man ein Property auszulesen. Wenn dies nicht funktioniert, wird ein Default-Wert zurückgegeben
' * @param  Object      Objekt welches das Property beinhalten sollte
' * @param  Name        Eigenschaftsname
' * @param  Variant     Default-Wert, falls die Eigenschaft nicht exisitiert
' * @return Variant
' */
Private Function getProperty(ByRef iObject As Object, ByVal iName As String, Optional ByRef iDefault As Variant = Null) As Variant
    On Error Resume Next
    If IsObject(iObject.properties(iName).value) Then: Set getProperty = iObject.properties(iName).value: Else: getProperty = iObject.properties(iName).value
    If Err.Number <> 0 Then
        If IsObject(iDefault) Then: Set getProperty = iDefault: Else: getProperty = iDefault
    End If
End Function
 
'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * mögliche Delemiter: @&!/~#=\|
' * mögliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      RegExp-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set sm = rxP.Execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function
 
'Version um in andere Module/Classen einzubauen
Private Sub ref(ByRef oNode As Variant, ByRef iNode As Variant)
    If IsObject(iNode) Then: Set oNode = iNode: Else: oNode = iNode
End Sub