Option Explicit
' Typdeklaration für API-Dialog->Verzeichnis auswählen'
Private Type BrowseInfo
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long
'Schalter
' False: Output erfolgt als normale Excel-txt-Datei
' True : Output erfolgt mit eigener Schreibroutine als txt-Datei
Private Const SCHALTER_EIGENESCHRIEBROUTINE As Boolean = True
Sub main_XLSAlsTXTTabSepariertSpeichern()
->Konvertiert *.xls zu *.txt, Tab separiert
->
->Pfad-Auswahl für zu konvertierende Arbeitsmappen
->Auswahl->Unterverzeichnisse einbeziehen'
->
->Speichert die xls-Datei als Tabsparierte txt-Datei ab.
->Speicherort: Pfad der xls-Datei
->Überschreiben: ggf.vorhandene txt-Datei gleichen Namens wird überschrieben
->
->Mappen mit einem Arbeitsblatt
->Name: wie xls-Datei, nur mit Endung txt
->Mappen mit einem Arbeitsblatt
->Name: wie xls-Datei, aber um Namen des jeweiligen Arbeitsblattes erweitert
-> ,Endung txt
->
->Dateien mit gleichem Namen wie die makro-Datei werden von der Konvertierung ausgeschlossen
Dim i As Long, ret As Integer, sDateiname As String
Dim sPfad As String, sDateinameFull As String, bSubFolders As Boolean
->Pruefen, ob nur diese Mappe geöffnet ist
If Application.Workbooks.Count <> 1 Then
MsgBox _
Bitte schliessen sie alle Mappen, bis auf die Mappe mit dem Makro & _
vbLf & ThisWorkbook.Name
Exit Sub
End If
->Wurzelverzeichnis abfragen
sPfad = VerzeichnisWaehlen(Verzeichnis der zu konvertierenden Arbeitsmappen auswählen)
If sPfad = Then Exit Sub-> Abbruch ?
->Abfrage mit/ohne Sub-Directories
ret = MsgBox( _
Sollen die Unterverzeichnisse einbezogen werden?, _
vbYesNoCancel + vbDefaultButton2 + vbQuestion, _
Auswahl mit/ohne Unterverzeichnisse)
If ret = vbYes Then
bSubFolders = True
ElseIf ret = vbNo Then
bSubFolders = False
Else
Exit Sub->Abbruch
End If
Application.ScreenUpdating = False
->Files suchen und konvertieren
With Application.FileSearch
.NewSearch
.LookIn = sPfad
.SearchSubFolders = bSubFolders
.FileType = msoFileTypeExcelWorkbooks
.Execute
->alle gefundenen files
For i = 1 To .FoundFiles.Count
sDateinameFull = .FoundFiles(i)
sDateiname = DateinameAusDateinameFull(sDateinameFull)
->Datei gleichen Namens wie die Makro-Datei von Konvertierung ausschliessen
If LCase(ThisWorkbook.Name) <> LCase(sDateiname) Then
Application.StatusBar = sDateinameFull
->File konvertieren
If Not EineDateiXLSAlsTXTTabSepariertSpeichern(sDateinameFull) Then
MsgBox Fehler bei Konvertierung. & vbLf & sDateinameFull
End If
Application.StatusBar =
DoEvents
End If
Next
End With
Application.ScreenUpdating = True
End Sub
'**********************************************************************************
Private Function EineDateiXLSAlsTXTTabSepariertSpeichern(sDateinameFull As String)
'**********************************************************************************
->Speichert die xls-Datei als Tabsparierte txt-Datei ab.
->Speicherort: Pfad der xls-Datei
->Überschreiben: ggf.vorhandene txt-Datei gleichen Namens wird überschrieben
->Mappen mit einem Arbeitsblatt
->Name: wie xls-Datei, nur mit Endung txt
->Mappen mit einem Arbeitsblatt
->Name: wie xls-Datei, aber um Namen des jeweiligen Arbeitsblattes erweitert
-> ,Endung txt
Dim wb As Workbook
EineDateiXLSAlsTXTTabSepariertSpeichern = False
->Datei-Endung prüfen
If LCase(Right(sDateinameFull, 4)) = .xls Then
->prüfen, ob Datei existiert
If Dir(sDateinameFull, vbNormal) <> Then
If DateiOeffnen(sDateinameFull, wb) Then
->Mappenschutz entfernen
If MappenschutzEntfernen(wb) Then
->Blattschutz entfernen
If BlattschutzEntfernen(wb) Then
->Blaetter bearbeiten
If SCHALTER_EIGENESCHRIEBROUTINE Then
->eigene Schreibroutine wird benutzt
If Not BlaetterBearbeiten2(wb) Then
MsgBox Blatt/Blätter konnten nicht gespeichert werden. & vbLf & wb.FullName
Else
EineDateiXLSAlsTXTTabSepariertSpeichern = True
End If
Else
->normale Excel-Txt-Datei schreiben
If Not BlaetterBearbeiten(wb) Then
MsgBox Blatt/Blätter konnten nicht gespeichert werden. & vbLf & wb.FullName
Else
EineDateiXLSAlsTXTTabSepariertSpeichern = True
End If
End If
Else
MsgBox Blattschutz läßt sich nicht entfernen. & vbLf & wb.FullName
End If
Else
MsgBox Mappenschutz läßt sich nicht entfernen. & vbLf & wb.FullName
End If
wb.Close savechanges:=False
Else
MsgBox Datei kann nicht geöffnet werden. & vbLf & sDateinameFull
End If
Else
MsgBox Datei nicht vorhanden. & vbLf & sDateinameFull: GoTo AUFRAEUMEN
End If
Else
MsgBox Datei-Endung <> .xls . & vbLf & sDateinameFull: GoTo AUFRAEUMEN
End If
AUFRAEUMEN:
Set wb = Nothing
End Function
'**********************************************************************************
Private Function BlaetterBearbeiten(wb As Workbook) As Boolean
'**********************************************************************************
->Voraussetzung: kein Mappenschutz
->Voraussetzung: kein Blattschutz
Dim ws As Worksheet
Dim sDateiname As String, sPfad As String, sDateinameFull As String
Dim BN() As String, BNCnt As Long, sDateinameFulltmp As String
Dim x As Long
BNCnt = 0: ReDim BN(1 To 1)
BlaetterBearbeiten = False
->Pfad und Dateiname der Ursprungsdatei
sDateiname = wb.Name: sPfad = wb.Path: sDateinameFull = wb.FullName
->Arbeitsblattnamen feststellen
For Each ws In wb.Worksheets
If ws.Type = xlWorksheet Then
BNCnt = BNCnt + 1: ReDim Preserve BN(1 To BNCnt): BN(BNCnt) = ws.Name
End If
Next
If BNCnt < 1 Then
MsgBox Kein Arbeitsblatt enthalten. & vbLf & wb.FullName
ElseIf BNCnt = 1 Then
->Mappe mit einem Arbeitsblatt
Application.DisplayAlerts = False
wb.SaveAs _
FileName:=Left(sDateinameFull, Len(sDateinameFull) - 4) & .txt, _
FileFormat:=xlText
Application.DisplayAlerts = True
BlaetterBearbeiten = True
Else
->Mappe mit mehreren Blättern
->Über alle Arbeitsblätter
For x = 1 To BNCnt
->Namen um Blattnamen erweitern
sDateinameFulltmp = Left(sDateinameFull, Len(sDateinameFull) - 4) & _ & BN(x) & .txt
->alle Blätter bis auf das betreffende entfernen
Application.DisplayAlerts = False
For Each ws In wb.Worksheets
If ws.Name <> BN(x) Then ws.Delete
Next
wb.SaveAs FileName:=sDateinameFulltmp, FileFormat:=xlText
wb.Close savechanges:=False
Application.DisplayAlerts = True
Call DateiOeffnen(sDateinameFull, wb)->Ursprungs-Datei wieder öffnen
Call MappenschutzEntfernen(wb) ->Mappenschutz entfernen
Call BlattschutzEntfernen(wb) 'Blattschutz entfernen
DoEvents
Next
BlaetterBearbeiten = True
End If
AUFRAEUMEN:
Set ws = Nothing
End Function
'**********************************************************************************
Private Function DateiOeffnen(sDateinameFull As String, wb As Workbook)
'**********************************************************************************
DateiOeffnen = True
On Error Resume Next
Application.DisplayAlerts = False
->wichtig UpdateLinks=0, bedeutet keine Aktuallisierung von Bezügen
Set wb = Workbooks.Open(FileName:=sDateinameFull, _
UpdateLinks:=0, _
ReadOnly:=False, _
Password:=, _
WriteResPassword:=, _
IgnoreReadOnlyRecommended:=True, _
AddToMru:=False)
Application.DisplayAlerts = True
If Err.Number <> 0 Then Err.Clear: DateiOeffnen = False
On Error GoTo 0
End Function
'**********************************************************************************
Private Function MappenschutzEntfernen(wb As Workbook) As Boolean
'**********************************************************************************
Dim b_ProtectWindows As Boolean, b_ProtectStructure As Boolean
MappenschutzEntfernen = True
b_ProtectWindows = wb.ProtectWindows
b_ProtectStructure = wb.ProtectStructure
If b_ProtectWindows Or b_ProtectStructure Then
On Error Resume Next
Application.DisplayAlerts = False
->Testen, ob sich der Mappenschutz entfernen läßt
wb.Unprotect Password:=
Application.DisplayAlerts = True
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MappenschutzEntfernen = False
End If
End If
End Function
'**********************************************************************************
Private Function BlattschutzEntfernen(wb As Workbook) As Boolean
'**********************************************************************************
Dim ws As Worksheet
Dim b_ProtectContents As Boolean, b_ProtectDrawingObjects As Boolean, b_ProtectScenarios As Boolean
Dim b_ProtectUserInterfaceOnly As Boolean->Schutz für Makros
BlattschutzEntfernen = True
For Each ws In wb.Worksheets
b_ProtectContents = ws.ProtectContents
b_ProtectDrawingObjects = ws.ProtectDrawingObjects
b_ProtectScenarios = ws.ProtectScenarios
b_ProtectUserInterfaceOnly = ws.ProtectionMode
If b_ProtectContents Or b_ProtectDrawingObjects Or b_ProtectScenarios Or _
b_ProtectUserInterfaceOnly Then
On Error Resume Next
Application.DisplayAlerts = False
->Testen, ob sich der Blattschutz entfernen läßt
ws.Unprotect Password:=
Application.DisplayAlerts = True
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
BlattschutzEntfernen = False
GoTo AUFRAEUMEN
End If
End If
Next
AUFRAEUMEN:
Set ws = Nothing
End Function
'***********************************************************
Private Function VerzeichnisWaehlen(Optional DialogTitel) As String
'***********************************************************
' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
Dim hWndAccessApp As Long
With StrukturVerzeichnisInfo
.hOwner = hWndAccessApp
.lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
.ulFlags = &H1-> BIF_RETURNONLYFSDIRS
End With
ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
Pfad = Space$(512)
If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWaehlen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
End Function
'***********************************************************
Private Function DateinameAusDateinameFull(sDateinameFull As String) As String
'***********************************************************
Dim pos As Long, posx As Long
pos = 0: posx = 0
Do
pos = InStr(pos + 1, sDateinameFull, Application.PathSeparator)
If pos > 0 Then posx = pos
Loop While pos <> 0
If posx = 0 Then
DateinameAusDateinameFull = sDateinameFull
Else
DateinameAusDateinameFull = Right(sDateinameFull, Len(sDateinameFull) - posx)
End If
End Function
'**********************************************************************************
Private Function BlaetterBearbeiten2(wb As Workbook) As Boolean
'**********************************************************************************
->Voraussetzung: kein Mappenschutz
->Voraussetzung: kein Blattschutz
Dim ws As Worksheet
Dim sDateiname As String, sPfad As String, sDateinameFull As String
Dim BN() As String, BNCnt As Long, sDateinameFulltmp As String
Dim x As Long
BNCnt = 0: ReDim BN(1 To 1)
BlaetterBearbeiten2 = False
->Pfad und Dateiname der Ursprungsdatei
sDateiname = wb.Name: sPfad = wb.Path: sDateinameFull = wb.FullName
->Arbeitsblattnamen feststellen
For Each ws In wb.Worksheets
If ws.Type = xlWorksheet Then
BNCnt = BNCnt + 1: ReDim Preserve BN(1 To BNCnt): BN(BNCnt) = ws.Name
End If
Next
If BNCnt < 1 Then
MsgBox Kein Arbeitsblatt enthalten. & vbLf & wb.FullName
ElseIf BNCnt = 1 Then
->Mappe mit einem Arbeitsblatt
sDateinameFulltmp = Left(sDateinameFull, Len(sDateinameFull) - 4) & .txt
Call TextdateiSchreiben(wb.Worksheets(BN(1)), sDateinameFulltmp)
BlaetterBearbeiten2 = True
Else
->Mappe mit mehreren Blättern
->Über alle Arbeitsblätter
For x = 1 To BNCnt
->Namen um Blattnamen erweitern
sDateinameFulltmp = Left(sDateinameFull, Len(sDateinameFull) - 4) & _ & BN(x) & .txt
Call TextdateiSchreiben(wb.Worksheets(BN(x)), sDateinameFulltmp)
DoEvents
Next
BlaetterBearbeiten2 = True
End If
AUFRAEUMEN:
Set ws = Nothing
End Function
'**********************************************************************************
Function TextdateiSchreiben(ws As Worksheet, sInputDateiname As String)
Dim DateiHandle As Integer
Dim Rng As Range
Dim Fcol As Long, Lcol As Long, Frow As Long, LRow As Long
Dim i As Long, j As Long, s As String, s2 As String
Dim outputLine As String
If sInputDateiname <> Then
DateiHandle = FreeFile
Open sInputDateiname For Output As #DateiHandle
Set Rng = ws.UsedRange
Fcol = Rng.Column
Lcol = Rng.Column + Rng.Columns.Count - 1
Frow = Rng.Row
LRow = Rng.Row + Rng.Rows.Count - 1
For i = Frow To LRow
outputLine =
For j = Fcol To Lcol
s = Replace(Trim(ws.Cells(i, j)), , ?)
On Error Resume Next
s2 = CDbl(s)
If Err.Number <> 0 Then
Err.Clear
Else
s = CStr(Round(CDbl(s), 3))
End If
On Error GoTo 0
outputLine = outputLine & & s & &
Next j
outputLine = Trim(outputLine)
outputLine = Replace(outputLine, , Chr(9))
outputLine = Replace(outputLine, ?, )
-><<< Hier könnte man noch Leerzeilen abfragen <<<
Print #DateiHandle, outputLine
Next i
Close #DateiHandle
End If
AUFRAEUMEN:
Set Rng = Nothing
End Function
'**********************************************************************************
'Funktion erst ab Excel 2000 vorhanden, daher Ersatzfunktion für EXCEL97
Private Function Round(ByVal dZahl As Double, ByVal AnzNachkommastellen As Integer) As Double
Round = Int(dZahl * 10 ^ AnzNachkommastellen + 0.5) / 10 ^ AnzNachkommastellen
End Function
'**********************************************************************************
'Funktion erst ab Excel 2000 vorhanden, daher Ersatzfunktion für EXCEL97
Private Function Replace(ByVal T As String, ByVal s As String, ByVal E As String) As String
Dim pos As Long
If T = Or s = Then Replace = : Exit Function
pos = 1
Do
pos = InStr(pos, T, s, 1)
If pos = 0 Then Exit Do
T = Left(T, pos - 1) & E & Right(T, Len(T) - pos - Len(s) + 1)
pos = pos + Len(E)
Loop
Replace = T
End Function
