This is an old revision of the document!
Die Klasse hat versteckte Attribute. Damit diese aktiv übernommen werden reicht es nicht aus, den Code in ein neues Modul zu kopieren. Man muss das Modul aus der Datei nach VBA importieren.
Bild zum Import
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 _ )
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
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