fertiges Programm
da die Shell erst beendet sein muß, bevor Excel-VBa weitermachen darf, hab ich noch die zusätzliche Funktion wait gebraucht die ich auf http://www.thescarms.com/vbasic/wait.aspx gefunden und angepasst habe
Kommentierung ist noch nicht ganz fertig, aber dazu komm ich heut nicht mehr!
Option Explicit
Private Sub CommandButton1\_Click()
Dim pfad As String ' pfad zu den tar Dateien
Dim datei\_tar\_gz As String ' Dateiname.tar.gz
Dim datei\_tar As String ' Dateinmae.tar
Dim anzahl As Integer ' Anzahl der Dateien
Dim x As Integer ' Hilfvariable für Schleifen
Dim s As Long
pfad = Cells(1, 2) ' ="E:\messreihen\tar\" wird später als Übergabewert beim funktionsaufruf übergeben
Columns("E:h").ClearContents 'Ausgabezellen löschen -\> Datenfeld leider ungünstig, da variable anzahl der dateien
Cells(1, 5) = "Name" ' Überschriften für Tabelle
Cells(1, 6) = "Name ohne gz"
If Not Dir(pfad & "cop\*.\*") = "" Then Kill (pfad & "cop\*.\*") 'alte Datein aus dem copy Verzeichnis löschenlöschen
If Not Dir(pfad & "test\*.\*") = "" Then Kill (pfad & "test\*.\*") 'alte Datein aus dem test Verzeichnis löschen
datei\_tar\_gz = Dir(pfad & "\*.tar.gz") 'Vorlesen des ersten Dateinnamens
SetCurrentDirectory (pfad & "test\") 'Ausgabepfad auf test\ legen
Do
If VBA.FileLen(pfad & datei\_tar\_gz) \> 180000 Then ' Nur Dateien, die größer als 180kB sind kopieren (gibt übertragunsfehler)
Application.StatusBar = anzahl
anzahl = anzahl + 1
datei\_tar = Left(datei\_tar\_gz, Len(datei\_tar\_gz) - 3)
Worksheets(1).Cells(anzahl + 1, 6) = datei\_tar
Worksheets(1).Cells(anzahl + 1, 5) = datei\_tar\_gz
FileCopy pfad & datei\_tar\_gz, pfad & "cop\" & datei\_tar\_gz ' zu bearbeitende Datein nach cop\ kopieren
s = Shell("gunzip " & pfad & "cop\" & datei\_tar\_gz) 'Dateien entpacken
Wait (s)
s = Shell("tar xf " & pfad & "cop\" & datei\_tar)
Wait (s)
End If
datei\_tar\_gz = Dir
Loop Until datei\_tar\_gz = ""
Cells(1, 8) = anzahl 'Anzahl der tar Datein merken, später auch als Übergabe
Kill (pfad & "cop\*.\*")
Columns("E:G").Select
Selection.Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Datein nach Name sortieren, Name ist JJMMDDHHMMSS.tar.gz
Application.StatusBar = ""
End Sub
Public Function FolderExists(ByVal sFolder As String) As Boolean
Dim fs As Object, MyNewWb As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(sFolder) Then FolderExists = True
End Function
Function Fileexists(fname) As Boolean
If Dir(fname) "" Then \_
Fileexists = True \_
Else Fileexists = False
End Function
Function Wait(ByRef lPid)
Dim SYNCHRONIZE As Long
Dim INFINITE As Integer ' Wait forever
Dim lHnd As Long
Dim lRet As Long
If lPid 0 Then
lHnd = OpenProcess(SYNCHRONIZE, 0, lPid) 'Get a handle to the shelled process.
If lHnd 0 Then 'If successful, wait for the application to end and close the handle.
lRet = WaitForSingleObject(lHnd, INFINITE)
CloseHandle (lHnd)
End If
End If
End Function
und das in einem Modul
Option Explicit
Declare Function SetCurrentDirectory \_
Lib "kernel32" Alias "SetCurrentDirectoryA" \_
(ByVal lpPathName As String) As Long
Declare Function OpenProcess Lib "kernel32" ( \_
ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, \_
ByVal dwProcessId As Long) As Long
Declare Function WaitForSingleObject Lib "kernel32" ( \_
ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Declare Function CloseHandle Lib "kernel32" ( \_
ByVal hObject As Long) As Long
