Rubrik: Dateisystem · Dateien allgemein | VB-Versionen: VB6 | 08.07.03 |
Dateien verpacken und extrahieren Tipp, wie man einfach mehrere Dateien in eine packt und diese wieder ausliest. | ||
Autor: Sascha Kurth | Bewertung: | Views: 17.897 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Zuerst muss die Dateiliste für den Parameter der Funktion MakeOneFile vorbereitet werden. Die einzelnen Dateinamen müssen samt Pfad, durch das Zeichen Chr(0) getrennt, in einer Variable gespeichert werden.
Beispiel:
"C:\Datei1.exe" & Chr(0) & "C:\Datei2.exe" & Chr(0) & "C:\Datei3.exe"
Die Funktionen:
Function MakeOneFile(pFiles As String, _ Optional ByVal sPath As String = "") As Boolean Dim ff As Integer ' FreeFile zum öffnen der Dateien Dim i As Integer ' Zählervariable Dim sName As String * 128 ' String mit Dateiname (128 Zeichen Länge) Dim sSize As String * 10 ' String mit Dateigröße (10 Zeichen Länge) Dim sData As String ' String mit Dateiinhalt Dim sFiles() As String ' Dateipfade/namen On Error GoTo ErrHandler ' Dateipfad festlegen: Applikationsverzeichnis + ' Dateiname ("files.dat") ' Die Änderung des Pfades/Dateinamens ist ' problemlos möglich If sPath = "" Then sPath = App.Path & IIf(Right(App.Path, 1) = "\", "", "\") & _ "files.dat" End If ' Wenn vorhanden Trennzeichen (Chr(0)) am Ende entfernen If Right(pFiles, 1) = Chr(0) Then pFiles = _ Left(pFiles, Len(pFiles) - 1) ' Prüfen, ob Parameter mehr als eine Datei enthält If InStr(1, pFiles, Chr(0)) > 0 Then ' Parameter pFiles in einzelne Dateinamen splitten ' (Trennzeichne ist Chr(0)) sFiles = Split(pFiles, Chr(0)) ' Wenn die Ergebnisdatei schon existiert, soll ' diese gelöscht werden If Dir(sPath) <> "" Then Kill sPath ' Alle Dateien im Array sFiles durchlaufen For i = 0 To UBound(sFiles) ' Prüfen, ob Datei existiert, wenn nicht zur ' nächsten Datei gehen If Dir(sFiles(i)) <> "" Then ' sName wird auf den Dateinamen (ohne ' Pfadangabe) gesetzt sName = Right(sFiles(i), Len(sFiles(i)) - _ InStrRev(sFiles(i), "\")) ' sSize wird auf die Dateigröße gesetzt sSize = FileLen(sFiles(i)) ' Dateinummer zum Öffnen bestimmen ff = FreeFile ' Datei öffnen und Inhalt in der Variable ' sData speichern Open sFiles(i) For Binary As ff sData = Space(LOF(ff)) Get #ff, , sData Close ff ' Dateinummer zum Öffnen bestimmen ff = FreeFile ' Enddatei öffnen und ans Ende springen Open sPath For Binary As ff Seek #ff, LOF(ff) + 1 ' Den Namen, die Größe und den Dateiinhalt am ' Ende der Datei speichern Put #ff, , CStr(sName & sSize & sData) Close ff End If Next MakeOneFile = True Else MsgBox "Eine oder keine Dateien angegeben!" & vbCrLf & _ "Zusammenfassen der Datei(en) nicht nötig/möglich", _ vbCritical, "Fehler" MakeOneFile = False End If Exit Function ErrHandler: MsgBox Err.Number & ": " & Err.Description, _ vbCritical, "Fehler" MakeOneFile = False End Function
Function ExtractFiles(sFilePath As String, _ Optional ByVal sPath As String = "") As Boolean Dim sFileData As String ' Dateiinhalt der .dat-Datei Dim sName As String ' Dateiname Dim sSize As String ' Dateigröße (wichtig zum extrahieren) Dim sData As String ' Dateiinhalt der extrahierten Datei Dim ff As Integer ' FreeFile zum öffnen der Dateien ' Bei einem Fehler zur definierten Sprungmarke gehen On Error GoTo ErrHandler ' Pfad zur Extraktion setzen. Dieser ist problemlos ' änderbar (Wichtig ist das "\" am Ende) If sPath = "" Then sPath = App.Path sPath = sPath & IIf(Right(sPath, 1) = "\", "", "\") ' Dateinummer zum Öffnen bestimmen ff = FreeFile ' Datei öffnen und Inhalt in Variable ' sFileData speichern Open sFilePath For Binary As ff sFileData = Space(LOF(ff)) Get #ff, , sFileData Close ff While Len(sFileData) > 0 ' Dateinamen aus sFileData filtern und ' rechtsstehende Leerzeichen abtrennen sName = RTrim(Left(sFileData, 128)) ' Dateigröße aus sFileData filtern und ' rechtsstehende Leerzeichen abtrennen sSize = RTrim(Mid(sFileData, 129, 10)) ' Dateiinhalt aus sFileData lesen sData = Mid(sFileData, 139, sSize) ' Dateinummer zum Öffnen bestimmen ff = FreeFile ' Wenn die zu extrahierende Datei bereits besteht, ' diese löschen If Dir(sPath & sName) <> "" Then Kill sPath & sName ' Datei öffnen und Dateiinhalt abspeichern Open sPath & sName For Binary As ff Put #ff, , CStr(sData) Close ff ' Bereits extrahierten Teil aus sFileData entfernen sFileData = Right(sFileData, Len(sFileData) - _ 138 - sSize) ExtractFiles = True Wend Exit Function ErrHandler: MsgBox Err.Number & ": " & Err.Description, _ vbCritical, "Fehler" ExtractFiles = False End Function