Liebe Programmiererkollegen,
da ich auch immer noch einige Programme in VB6 warten und erweitern muss, kommt es immer noch vor, dass ich eigene Funktionen dafür schreiben muss.
Bis jetzt hatte ich in den Programmen einen EXCEL-Export welcher mit wenigen Zeilen von Access selbst gemacht werden konnte.
Seit einem der letzten Windows-Updates funktioniert das aber unter Win7, Win8 und Win10 nicht mehr.
Daher habe ich diese Tage einen manuellen Export in CSV geschrieben.
Übergeben wird der Routine lediglich die Datenbank, die zu exportierende Tabelle, ggf. ein Datenbankpasswort, ein optionaler SQL-Sortierstring und die Zieldatei.
Aufgerufen wirds so:
Hier der Code:
Ich hoffe dieser Code kann einigen von Euch hilfreich sein.
LG Roland
da ich auch immer noch einige Programme in VB6 warten und erweitern muss, kommt es immer noch vor, dass ich eigene Funktionen dafür schreiben muss.
Bis jetzt hatte ich in den Programmen einen EXCEL-Export welcher mit wenigen Zeilen von Access selbst gemacht werden konnte.
Seit einem der letzten Windows-Updates funktioniert das aber unter Win7, Win8 und Win10 nicht mehr.
Daher habe ich diese Tage einen manuellen Export in CSV geschrieben.
Übergeben wird der Routine lediglich die Datenbank, die zu exportierende Tabelle, ggf. ein Datenbankpasswort, ein optionaler SQL-Sortierstring und die Zieldatei.
Aufgerufen wirds so:
Hier der Code:
Visual Basic-Quellcode
- ''' Exportiert eine Tabelle einer Access-Datenbank in eine CSV-Datei
- ''' Datensätze werden mit Semikolon getrennt
- ''' Export über Access-Funktionen nicht zufriedenstellend, daher diese "manuelle" Methode
- Public Sub ExportCSV(ByVal sDBFile As String, ByVal sTable As String, ByVal sExportFile As String, Optional ByVal sPassword As String = "", Optional Sortierung As String = "")
- 'vorhandene CSV-Datei löschen falls vorhanden
- Dim TextExportFile As String
- TextExportFile = sExportFile & ".csv"
- If Dir(TextExportFile) <> "" Then
- On Error Resume Next
- Kill TextExportFile
- On Error GoTo 0
- End If
- 'Datenbank öffnen
- Dim Cn As New ADODB.Connection
- Dim rs As New ADODB.Recordset
- Dim strSQL As String
- Cn.CursorLocation = adUseServer
- Cn.Provider = "Microsoft.jet.OLEDB.4.0"
- Cn.ConnectionString = "Data Source=" + sDBFile & ";" & "Jet OLEDB:Database Password=" & sPassword
- Cn.Open
- strSQL = "SELECT * FROM " & sTable & Sortierung
- rs.Open strSQL, Cn, 3, 3
- Set FS = CreateObject("Scripting.FileSystemObject")
- Set F = FS.CreateTextFile(TextExportFile, True)
- Dim Spaltenanzahl As Integer
- Dim CSVHeader As String
- CSVHeader = ""
- Spaltenanzahl = rs.Fields.Count
- For I = 0 To Spaltenanzahl - 1
- CSVHeader = CSVHeader + UCase(rs.Fields(I).name) + ";"
- Next I
- CSVHeader = Left(CSVHeader, Len(CSVHeader) - 1)
- 'Kompletter CSV-Inhalt
- Dim TextInhalt As String
- TextInhalt = ""
- 'Zeileninhalt
- Dim ZeilenInhalt As String
- 'Datensatzzähler
- Dim Zaehler As Integer
- Zaehler = 0
- 'Maximale Datenbankanzahl auslesen falls Datensätze existieren
- Dim MaxRS As String
- If Not rs.EOF Then
- rs.MoveLast
- MaxRS = CStr(rs.RecordCount)
- rs.MoveFirst
- End If
- 'Header schreiben
- F.WriteLine CSVHeader
- While Not rs.EOF
- ZeilenInhalt = ""
- For I = 0 To Spaltenanzahl - 2
- 'ab der ersten Spalte bis zur vorletzten Spalte Semikolon anhängen (aber in den einzelnen Datensätzen rausnehmen)
- ZeilenInhalt = ZeilenInhalt + Replace(CStr(rs.Fields(I) & ""), ";", "") + ";"
- Next I
- 'in der letzten Zeile kein Semikolon anhängen (aber in den einzelnen Datensätzen rausnehmen)
- ZeilenInhalt = ZeilenInhalt + Replace(CStr(rs.Fields(Spaltenanzahl - 1) & ""), ";", "")
- 'Zeilenumbrüche in Zeileninhalten entfernen
- ZeilenInhalt = Replace(ZeilenInhalt, vbCrLf, "")
- 'Zeilenumbruch nach komplettem CSV-Datensatz anhängen
- TextInhalt = TextInhalt + ZeilenInhalt + vbCrLf
- Zaehler = Zaehler + 1 'Datensatzzähler erhöhen
- rs.MoveNext 'nächster Datensatz in der Datenbank
- 'Alle 100 Datensäzte Status ausgeben (Optional)
- If Zaehler Mod 100 = 0 Then
- Label1.Caption = "Export " + CStr(Zaehler) + " von " + MaxRS
- DoEvents
- End If
- 'Alle 500 Datensätze in Zieldatei speichern, damit der String im Speicher nicht zu groß wird (wird sonst zu langsam)
- If Zaehler Mod 500 = 0 Then
- F.Write TextInhalt
- TextInhalt = ""
- End If
- Wend
- F.Write TextInhalt 'Restlichen Inhalt speichern
- F.Close
- rs.Close
- Set rs = Nothing
- Cn.Close
- Set Cn = Nothing
- End Sub
Ich hoffe dieser Code kann einigen von Euch hilfreich sein.
LG Roland
Liebe Grüße
Roland Berghöfer
Meine aktuellen und kostenlos verwendbaren Tools (mit VB.NET erstellt): freeremarkabletools.com | priconman.com | SimpleCalendar | AudibleTouch | BOComponent.com | bonit.at
Roland Berghöfer
Meine aktuellen und kostenlos verwendbaren Tools (mit VB.NET erstellt): freeremarkabletools.com | priconman.com | SimpleCalendar | AudibleTouch | BOComponent.com | bonit.at