Aktuellen Bericht nach Excel übergeben Beispiel: DoCmd.OutputTo acForm, Me.Name, "MicrosoftExcel(*.xls)", , True ABER: Normalerweise enthält der Bericht / das Formular auch Textfelder im Kopfbereich. Dann erscheinen diese Textfelder als Spalten in der EXCEL-Tabelle, was jedoch meist absolut nicht erwünscht ist! Mögliche Lösungen:
Jedenfalls habe ich (ca. 14 Tage) nicht locker gelassen und 2 brauchbare Funktionen gebaut. Die Funktionen funktionieren ziemlich sicher, solange die RecordSource des Berichts/ Fomulars halbwegs "normal" sind. Bei Verwendung von IN SELECT , INNER JOIN, UNION kann die Sache "schiefgehen" ... Dann kann man immernoch in Richtung Variante 1 disponieren. Die Funktionen ausprobieren kostet schließlich nur wenig Zeit und kein Geld. In der Beispiel-Datenbank (Download) kann man die Sache ausprobieren und die Module in andere Datenbanken importieren ... ' CODE fuer Bericht-Export (Formular-Export siehe Download) Option Compare Database Option Explicit Public Function ExportAktiverBerichtTest_000034() Call ExportBerichtNachExcel End Function Public Function ExportBerichtNachExcel(Optional TRY_Filter = True, _ Optional B_Name As String) ' **************************************************************************** ' Funktion exportiert den Detail-Bereich eines Berichts ' "tabellarisch" nach EXCEL. ' Es wird die aktuelle Anzeige exportiert einschl. ' Sortierung(en) und Spalten-Folge. ' PARAMETER: ' ' TRY_Filter: Versuchen, auch Berichts-Filter zu übernehmen, falls vorhanden ' (funktioniert wahrscheinlich nicht bei sehr komplexen Quellen, ' dann auf False setzen und/oder Berichts-Filter verbieten oder ' Irgendwas ausdenken .... ' Evtl. kann man auch auf Textfelder im Kopf/Fuss verzichten und ' einfach den direkten (Standard-) Export anwenden ... ' ' B_Name: Name des (geöffneten) Berichts ' ohne Angabe wird, falls zutreffend, der aktive Bericht verwendet. ' ' Dazu wird eine Abfrage erstellt, exportiert und wieder gelöscht. ' - Wenn im Bericht befindliche berechnende Controls mit exportiert ' werden sollen, kann man es mit entsprechenden Manipulationen ' (s. weiter...) versuchen. ' ' - Ähnliches gilt, wenn die Datenherkunft des Berichts etwas "komplexer" ist. ' ' - Die Funktion sollte für alle "halbwegs normalen" Berichte funktionieren. ' Man kann bestimmt noch einiges gezielter manipulieren. Aber es gibt ' bestimmt Berichte, bei denen der Export SO nicht geht. ' ' - Die (lästigen) Einträge und Objekte im Kopf/Fuss ect. werden ' NICHT mit-exportiert. ' ' - Die REIHENFOLGE DER SPALTEN soll korrekt exportiert werden. ' Die Reihenfolge für EXCEL wird aus der Controls-Auflistung des ' Berichts-Detailbereichs generiert. ' Dazu muss man nur die (betroffenen) Controls im Berichts-Detailbereich ' - Von LINKS nach RECHTS in den Vordergrund bringen oder ' - Von RECHTS nach LINKS in den Hintergrund bringen. ' (Im Berichts-Entwurf) . ' ' - Als Spalten-Überschriften werden in EXCEL die Namen der Controls im ' Berichts-Detailbereich verwendet. ' ' - Für die Sortierung werden ' Berichts-Sortierung (.OrderBy) (wirkt zuerst) UND ' Source-Sortierung ( SELECT ..... ORDER BY xxxxxxx ) (zweitrangig) ' ermittelt und angewendet. ' ' Empfehlung bei "Code-Meckern" (gilt allgemein): ' Den Verweis "Microsoft DAO 3.6 Object Library" an die 3. Stelle setzen. ' **************************************************************************** On Error GoTo ERR_01 Dim rep1 As Report Dim AbfName As String ' Name der temp. Abfrage Dim B_Source ' Recordsource des akt. Berichts Dim SEL_PR As String ' evtl. vorhandenes SELECT mit Prädikat ALL, DISTINCT ect... Dim SEL_ARR() ' Dyn. Datenfeld mit zu untersuchenden SELECT-Prädikaten' Dim STR_ARR() ' Dyn. Datenfeld für String-Manipulationen ect. Dim STR_ARR2() ' -;- Dim rst1 As Recordset ' RecordSet aus Recordsource des akt. Berichts Dim strSQL As String ' SQL-String zum Erstellen der temp. Abfrage Dim AbfTmp As QueryDef ' zum erstellen der temp. Abfrage Dim qdf1 As QueryDef ' Für Abf-Schleifen-Tests Dim fld1 As Field ' Für Field-Schleifen-Tests Dim ctl As Control ' Für Controlls-Schleifen-Tests Dim Pos1 ' Zeichen-Position für Tests Dim Test_STR ' temp. TestString Dim i ' Zähler Dim Z ' Zeichen Dim t1, t2, t3 ' Texte Dim bFound As Boolean ' --- B_Name akt. Bericht ermitteln, falls nicht angegeben ---- If Len(B_Name) = 0 Then If Not Screen.Application.CurrentObjectType = acReport Then MsgBox "1. Es ist kein Kein BerichtsName angegeben." & vbNewLine & vbNewLine & _ Space(29) & "&" & vbNewLine & vbNewLine & _ "2. Das aktive Objekt ist kein Bericht." & vbNewLine & vbNewLine Exit Function Else ' --- B_Name wird Name des aktiven Berichts ---- B_Name = Screen.Application.CurrentObjectName End If End If For Each rep1 In Reports If rep1.Name = B_Name Then bFound = True: Exit For Next rep1 If Not bFound Then MsgBox "Bericht " & B_Name & " ist nicht geöffnet " & _ (oder existiert nicht ?) !", vbInformation Exit Function End If B_Source = rep1.RecordSource ' Gibt FeldNamen der orig. Herkunft If Trim(B_Source) = "" Then MsgBox rep1.Name & " hat keine Datenherkunft !", vbInformation Exit Function End If ' Datensatzgruppe öffnen. Set rst1 = CurrentDb.OpenRecordset(B_Source, dbOpenSnapshot) i = rst1.RecordCount rst1.Close If i = 0 Then MsgBox rep1.Name & " hat keine aktuellen Datensätze !", vbInformation Exit Function End If ' --- Name-String ermitteln für evtl. zu erzeugende (temporäre) Abfrage --- ' --- (Wird auch der angebotene EXCEL-Tabellen-Name ) --- If "x" & Environ("COMPUTERNAME") = "x" Then AbfName = B_Name & "_" & "Admin" 'Notlösung Else AbfName = B_Name & "_" & Environ("COMPUTERNAME") End If ' Datensatzgruppe öffnen. Set rst1 = CurrentDb.OpenRecordset(B_Source, dbOpenSnapshot) ' Entsprechend der Controls im Berichts-Detailbereich (Von links ' nach rechts) aus deren ControlSource SQL-String entwickeln. ' Dyn. Datenfeld mit zu untersuchenden SELECT-Prädikaten (in logischer Folge !) ReDim SEL_ARR(5) SEL_ARR(1) = "SELECT DISTINCTROW " SEL_ARR(2) = "SELECT DISTINCT " SEL_ARR(3) = "SELECT TOP " SEL_ARR(4) = "SELECT ALL " SEL_ARR(5) = "SELECT " For i = 1 To UBound(SEL_ARR, 1) If InStr(1, B_Source, SEL_ARR(i)) > 0 Then strSQL = SEL_ARR(i) Exit For End If Next i If Len(strSQL) = 0 Then strSQL = "SELECT " ' "Normaler" Klausel-Anfang End If ' Control-Reihenfolge aus Bericht For Each ctl In rep1.Section(acDetail).Controls If ctl.ControlType = acTextBox Or _ ctl.ControlType = acComboBox Then For Each fld1 In rst1.Fields ' jedes Herkunfts-Feld If fld1.Name = ctl.ControlSource Then ' Control-Name gibt EXCEL-Spalten-Namen If ctl.Name = ctl.ControlSource Then ' 2006-10-22 Feldeigenschaften SourceTable SourceField nutzen !!! strSQL = strSQL & "[" & fld1.SourceTable & "]" & "." & _ "[" & fld1.SourceField & "]" & ", " Else ' 2006-10-22 Feldeigenschaften SourceTable SourceField nutzen !!! strSQL = strSQL & "cVar(" & "[" & fld1.SourceTable & "]" & "." & _ "[" & fld1.SourceField & "]" & ")" & " AS " & ctl.Name & ", " End If Exit For Else ' (Hier KANN man MANIPULIEREN, wenn's geht und was nützt...) ' Wahrscheinlich ein berechnendes Control (mit "=" links, ist ' evtl. Funktion ect.) ' mal versuchen.... Test_STR = ctl.ControlSource If Left(Test_STR, 1) = "=" Then Test_STR = Right(Test_STR, Len(Test_STR) - 1) ' links = wegnehmen strSQL = strSQL & Test_STR & " AS " & ctl.Name & ", " Exit For End If End If Next fld1 End If Next ctl rst1.Close ' Das letzte Komma und Leerzchn. wegschneiden! strSQL = Left(strSQL, Len(strSQL) - 2) strSQL = strSQL & " FROM " ' in strSQL Stehen jetzt alle notwendigen Feldnamen in richtiger ReihenFolge: ' SELECT ...... FROM ohne den noch notwendigen Rest. ' --- Ist die Herkunft eine SELECT-Klausel oder Tabelle/Abfrage ? Pos1 = InStr(1, B_Source, "SELECT ") If Pos1 = 1 Then ' Berichts-Herkunft ist eine Select-Klausel -> Tab/Abf- Name 'nach "FROM" rausfiltern: Pos1 = InStr(1, B_Source, " FROM ") If Pos1 = 0 Then MsgBox "Fehler, SELECT ohne FROM in Berichts-Source ...???" Exit Function End If ' An strSQL (=alles bis einschl. FROM) ' den rechten Teil der Berichts-RecordSorce (=alles nach FROM) anfügen: strSQL = strSQL & " " & Right(B_Source, Len(B_Source) - Pos1 - 5) ' --- evtl. linke und rechte Leerzeichen streichen !!!! --- strSQL = Trim(strSQL) ' --- evtl. rechtes ; streichen !!!! --- If Right(strSQL, 1) = ";" Then strSQL = Left(strSQL, Len(strSQL) - 1) ' Eigentlich ist jetzt alles komplett : SELECT...FROM... WHERE ...ORDER BY ... ' Weil im Bericht Sortierung .OrderBy vorrangig vor ORDER BY wirkt, ' wird erst mal ORDER BY weggeschnitten . ' Nachher werden dann nacheinander BEIDE Sortierungen angefügt. Pos1 = InStr(1, strSQL, " ORDER BY ") If Pos1 > 0 Then strSQL = Left(strSQL, Pos1) Else ' RecordSource ist NUR ein einzelner Tabellen-/Abf-Name strSQL = strSQL & " " & B_Source End If ' Abfrage löschen, falls beim letzten mal nicht gelöscht werden konnte ! For Each qdf1 In CurrentDb.QueryDefs If qdf1.Name = AbfName Then CurrentDb.QueryDefs.Delete AbfName End If Next qdf1 ' Sortierung ermitteln, Berichts-Sortierung geht vor Berichts-Source-Sortierung ' Deshalb zuerst eventuelle Berichts-Sortierung ermitteln: Test_STR = "" If Len(rep1.OrderBy) > 0 And rep1.OrderByOn = True Then ' --- Sortier-Terme ermitteln ----- STR_ARR = Array(rep1.OrderBy) ' Doll,speichern aller Sortierungen.. For i = 0 To UBound(STR_ARR, 1) ReDim Preserve STR_ARR2(4, i + 1) STR_ARR2(0, i + 1) = STR_ARR(i) ' Ganzer Term in 0-Spalte' STR_ARR2(1, i + 1) = STR_ARR(i) ' Ganzer Term in 1-Spalte' STR_ARR2(2, i + 1) = STR_ARR(i) ' Ganzer Term in 2-Spalte' Pos1 = InStr(1, STR_ARR(i), ".") If Pos1 > 0 Then ' Kürzen,Herk.-Form Abf-entfernen STR_ARR2(1, i + 1) = Right(STR_ARR(i), Len(STR_ARR(i)) - Pos1) STR_ARR2(2, i + 1) = STR_ARR2(1, i + 1) End If STR_ARR2(2, i + 1) = ErsetzenTextTeil_03(STR_ARR2(2, i + 1), _ "[", "") 'FeldName ohne "["' STR_ARR2(2, i + 1) = ErsetzenTextTeil_03(STR_ARR2(2, i + 1), _ "]", "") 'FeldName ohne "]"' ' evtl. DESC raus aus 2-Spalte und merken in 3-Spalte Pos1 = InStr(1, STR_ARR2(2, i + 1), " DESC") If Pos1 > 0 Then ' 2-Spalte ohne " DESC" STR_ARR2(2, i + 1) = ErsetzenTextTeil_03(STR_ARR2(2, i + 1), " DESC", "") ' DESC merken in 3-Spalte STR_ARR2(3, i + 1) = "DESC" End If ' Z = Z & STR_ARR2(0, i + 1) & "; " & STR_ARR2(1, i + 1) & "; " & _ ' STR_ARR2(2, i + 1) & "; " & STR_ARR2(3, i + 1) & vbNewLine Next i ' MsgBox Z ' Feldinhalte von STR_ARR2 sehen jetzt zB. so aus: ' STR_ARR2(0,1) [Abf_TestTab].[Text1] DESC ' STR_ARR2(1,1) [Text1] DESC 'wird später verwendet ! ' STR_ARR2(2,1) Text1 '=Feldname ! (sum suchen der SourceTab) ' STR_ARR2(3,1) DESC ' STR_ARR2(4,1) (SourceTable, noch leer) 'wird später verwendet ! ' ---- SourceTable-Namen für die Felder ermitteln ------------ ' Datensatzgruppe öffnen. Set rst1 = CurrentDb.OpenRecordset(B_Source, dbOpenSnapshot) For i = 1 To UBound(STR_ARR2, 2) ' Z = Z & STR_ARR2(0, i) & "; " & STR_ARR2(1, i) & "; " & _ ' STR_ARR2(2, i) & "; " & STR_ARR2(3, i) & "; " For Each fld1 In rst1.Fields If fld1.Name = Trim(STR_ARR2(2, i)) Then STR_ARR2(4, i) = fld1.SourceTable Exit For ' Z = Z & STR_ARR2(4, i) & "; " End If Next fld1 ' Z = Z & vbNewLine Next i rst1.Close ' MsgBox Z ' ---- ORDER - String aus Source-Tabellen und Feldnamen bilden ------- For i = 1 To UBound(STR_ARR2, 2) Test_STR = Test_STR & "[" & STR_ARR2(4, i) & "]" & "." & STR_ARR2(1, i) & ", " Next i Test_STR = Trim(Test_STR) ' rechtes Leerz. wegnehmen If Right(Test_STR, 1) = "," Then Test_STR = Left(Test_STR, Len(Test_STR) - 1) ' rechtes Komma wegnehmen End If ' MsgBox Test_STR End If ' Erst jetzt eventuelle Sortierung aus Berichts-Source ermitteln + anhängen: Pos1 = InStr(1, B_Source, " ORDER BY ") If Pos1 > 0 Then If Len(Test_STR) > 0 Then Test_STR = Test_STR & "," ' Komma für die folgende Erweiterung End If Test_STR = Test_STR & " " & Right(B_Source, Len(B_Source) - Pos1 - 9) End If ' MsgBox strSQL & " " & Test_STR ' ---- Übernahme der ermittelten beiden Sortierungen ---- If Len(Test_STR) > 0 Then ' aktuelle Sortierung übernehmen: strSQL = strSQL & " ORDER BY " & Test_STR End If ' Filter ? Jetzt wird es noch confuser, aber es geht und danach ist Schluss ' Evtl. ist im Bericht ein Filter aktiviert. Dieser Filter lässt sich zwar per ' Set prp1 = qdf1.CreateProperty("Filter", dbText) in die Abfrage einbauen, ' ist jedoch nicht wirksam, auch nicht mit neu erstellter FilterOn-Eigenschaft. ' Die Filter-Eigenschaft bei Abfragen dient wohl nur zum Vererben auf neue Formulare... ' ' Also wird jetzt mühselig versucht, ' den Berichts-Filter in den WHERE-Abschnitt von strSQL einzubauen: ' (SELECT und FROM sind auf jeden Fall bereits in strSQL .) ' ' - WHERE bereits vorhanden --> Filter + " AND " direkt hinter "WHERE " ' - WHERE nicht vorhanden --> WHERE und Filter hinter "FROM <TabAbfName> " ' ************************************************************************************* If TRY_Filter = False Then GoTo END_FILTER ' nicht notwendig If rep1.FilterOn = False Then GoTo END_FILTER ' nicht notwendig If Len(rep1.Filter) = 0 Then GoTo END_FILTER ' nicht notwendig Pos1 = InStr(1, strSQL, " WHERE ") If Pos1 > 0 Then ' MsgBox " WHERE vorhanden" ' WHERE vorhanden, Filter + " AND " direkt hinter "WHERE " (erstes Vorkommen ersetzen) strSQL = ErsetzenTextTeil_04(strSQL, " WHERE ", " WHERE " & rep1.Filter & " AND ") Else ' WHERE noch NICHT vorhanden, WHERE und Filter hinter "FROM <TabAbfName> " einfügen ' -> Tab/Abf-Name ermitteln: Pos1 = InStr(1, strSQL, " FROM ") 'Pos erstes " FROM " ermitteln, muss existieren ! Pos1 = Pos1 + 6 ' An dieser Pos. sollte der Tab/Abf-Name anfangen Do Until Not Mid(strSQL, Pos1, 1) = " " ' Sicherheit An Genau dieser Pos. muss der Tab/Abf-Name anfangen Pos1 = Pos1 + 1 Loop i = 0 Test_STR = "" ' Bis " " oder Ende von strSQL Do Until Mid(strSQL, Pos1, 1) = " " Or Mid(strSQL, Pos1, 1) = "" i = i + 1 ' MsgBox "Herkunft: " & Chr(34) & Test_STR & Chr(34) ' Name der Herkunfts-Tab/Abf ergänzen Test_STR = Test_STR & Mid(strSQL, Pos1, 1) Pos1 = Pos1 + 1 If i > 55 Then t1 = "-------- FEHLER Überlauf bei Filter-Übernahme ! -----------------" & _ vbNewLine & vbNewLine t2 = "ExportBerichtNachExcel(Optional ...):" & vbNewLine t3 = "Konnte Herkunfts-Tabelle/Abfrage-Namen nich ermitteln" & _ vbNewLine & vbNewLine MsgBox Chr(34) & Test_STR & Chr(34) & vbNewLine & strSQL MsgBox t1 & t2 & t3, vbCritical Exit Function End If Loop ' In Test_STR steht jetzt der Name der Herkunfts-Tab/Abf ' zwischen FROM u. <Tab/AbfName> können tatsächlich 1 oder 2 Leerzeichen sein ... If InStr(1, strSQL, " FROM " & Test_STR) > 0 Then ' MsgBox "1 Leerzeichen zwischen FROM u. <Tab/AbfName>" ' Filter anfügen... (erstes Vorkommen ersetzen) strSQL = ErsetzenTextTeil_04(strSQL, " FROM " & Test_STR, " FROM " & _ Test_STR & " WHERE " & rep1.Filter & " ") ElseIf InStr(1, strSQL, " FROM " & Test_STR) > 0 Then ' MsgBox "2 Leerzeichen zwischen FROM u. <Tab/AbfName>" ' Filter anfügen... (erstes Vorkommen ersetzen) strSQL = ErsetzenTextTeil_04(strSQL, " FROM " & Test_STR, " FROM " & _ Test_STR & " WHERE " & rep1.Filter & " ") End If End If END_FILTER: ' ********************************************************************* ' --- ENDLICH die Abfrage für den Export erstellen mit allem PiPaPo --- Set AbfTmp = CurrentDb.CreateQueryDef(AbfName) With AbfTmp .SQL = strSQL End With ' ********************************************************************* ' ---- EXCEL mit neuer Tabelle öffnen ----------- DoCmd.OutputTo acOutputQuery, AbfName, acFormatXLS, , True ' Abfrage löschen! (wird sonst alles beim nächsten mal sehr langsam ! For Each qdf1 In CurrentDb.QueryDefs If qdf1.Name = AbfName Then CurrentDb.QueryDefs.Delete AbfName End If Next qdf1 Exit Function ERR_01: Select Case Err.Number Case 2302 ' Fehler, EXCEL-Datei offen ... MsgBox "ExportBerichtNachExcel(Optional ...): " & vbNewLine & _ Err.Number & " " & Err.Description & vbNewLine & vbNewLine & _ "(Datei bereits offen ...? )" Resume Next Case 2501 ' Tabelle Speichern Abgebrochen... Resume Next Case Else MsgBox "ExportBerichtNachExcel(Optional ...): " & vbNewLine & _ Err.Number & " " & Err.Description End Select End Function Dieser Tipp wurde bereits 24.845 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevISDN 1.0 Überwachung aller eingehender Anrufe! Die DLL erkennt alle über die CAPI-Schnittstelle eingehenden Anrufe und teilt Ihnen sogar mit, aus welchem Ortsbereich der Anruf stammt. Weitere Highlights: Online-Rufident, Erkennung der Anrufbehandlung u.v.m. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Neu! sevPopUp 2.0 Dynamische Kontextmenüs! Erstellen Sie mit nur wenigen Zeilen Code Kontextmenüs dynamisch zur Laufzeit. Vordefinierte Styles (XP, Office, OfficeXP, Vista oder Windows 8) erleichtern die Anpassung an die eigenen Anwendung... |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |