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

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

Genauere Doumentaion folgt

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.

Diekombinierbaren Parameter für den Export Die Parameter können kompiniert werden. zB. xeReplaceExistFile+xeHasFieldNames

Public Enum xeParams
    xeNone = 0                  'Kein Parameter
    xeReplaceExistFile = 2 ^ 0  'Falls die Exportdatei bereits exisitert, kann diese ersetzt werden
    xeHasFieldNames = 2 ^ 1     'Feldnamen werden in die erste Zeile geschrieben
End Enum

object.export(source, filepath [,spreadsheettype [,params]])

Public Sub export( _
        ByRef iSource As Variant, _
        ByVal iFilePath As String, _
        Optional ByVal iSpreadSheetType As AcSpreadSheetType = acSpreadsheetTypeExcel12Xml, _
        Optional ByVal iParams As xeParams = xeReplaceExistFile + xeHasFieldNames _
)

• iSource Quelle. Tabellenname oder View-Name oder SQL-String
• iFilePath Export-Pfad. Pfad zur Datei dieerstellt werdn soll.
• iSpreadSheetType Excel-Format. Typ des Spreadsheets. Standart: Excel-12 XML
• iParams Parameters. verscheidene Parameter. Siehe Enumerator xeParams

Mit export()exportiert man eine Quelle in ein Excel-Sheet

Set object = XlsExporter.instance(source, filepath [,spreadsheettype [,params]])

Set object = XlsExporter(source, filepath [,spreadsheettype [,params]])

Eine neue Instanz der Klasse wird angelegt und der Export wird durchgeführt.

Die Parameter entsprechen denen der Methode export()

Die Methode instance() hat das versteckte Attribut Attribute instance.VB_UserMemId = 0. Dadurch lässt sie sich direkt aus der Klasse ausführen.

object.quit [save Yes/No]

Speicher das offene Workbook und schliesst die Datei und die Excelinstanz

range = object.range([Cell1 [,Cell2]])

range = object.sheet.range([Cell1 [,Cell2]])

Mit dem range-Property greifft man direkt auf das Worksheet mit den exporetierten Daten zu. Der Aufruf ist analog zu Excel. Mit dem Range kann man direkt Formatierungen etc. analog zu Excel-VBA im Excelsheet durchführen. Es ist identisch wie das .sheet.range. Aber da man den Range am meisten braucht, habe ich ihn extra hinzugefügt

sheet = object.sheet

Das sheet-Property gibt eine Referenz auf das Worksheet. Damit lassen sich ganz normale Worksheetbefehle absetzen

Erste Zeile und erste Spalte Fett setzen.

Dim exp As new XlsxExporter
exp.export "my_table", "c:\temp\__tt.xlsx"
exp.range("1:1").Font.Bold = True
exp.range("A:A").Font.Bold = True
exp.quit
Set exp=Nothing

Analog aber ohne feste Variablenzuordnung Da das Objekt nur temporär geöffnet ist (ist keiner Variable zugewiesen), wird am Ende des With das Objekt zerstört und somit quit() ausgeführt. Das muss also nicht expliziet gemacht werden

With XlsxExporter("my_table", "c:\temp\__tt.xlsx")
    .range("1:1").Font.Bold = True
    .range("A:A").Font.Bold = True
End With

Wenn man nur die Titelzeile formatieren will, gehts natrülich noch kürzer

XlsxExporter("my_table", "c:\temp\__tt.xlsx").range("1:1").Font.Bold = True

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