Ärgern Sie sich auch oft darüber, dass sich in einem Verzeichnis hunderte von kleinen Einzeldateien tummeln? Oder benötigt Ihre Anwendung viele zusätzliche Dateien, welche sie aber nicht alle einzeln installieren möchten? Was liegt also näher, alle Dateien eines Ordners in eine einzige Gesamtdatei zu packen und diese Gesamtdatei (Archivdatei) bei Bedarf wieder zu extrahieren? Eigentlich nichts - oder? Dann kann's ja losgehen! ' Bestimmte/Alle Dateien eines Verzeichnisses ' in eine "ArchivDatei" packen Public Function SaveFilesToArchiv( _ ByVal sPath As String, _ ByVal sArchiv As String, _ Optional ByVal sPattern As String = "*.*) As Long Dim F As Integer Dim N As Integer Dim nLenFileName As Integer Dim nLenFileData As Long Dim DirName As String Dim FileData As String Dim File() As String Dim nFiles As Long Dim I As Long Dim lngUBound AS long ' ggf. abschliessenden Backslash anfügen If Right$(sPath, 1) <> "\" Then sPath = sPath + "\" ' Dateien im Verzeichnis ermitteln nFiles = 0 DirName = Dir(sPath & sPattern, vbNormal) While DirName <> "" If DirName <> "." And DirName <> ".." Then nFiles = nFiles + 1 If nfiles > lngUBound Then lngUBound = 2 * nFiles ReDim Preserve File(lngUBound) File(nFiles) = DirName End If DirName = Dir Wend ReDim Preserve File(nFiles) ' Ggf. Archivdatei löschen If Dir(sArchiv) <> "" Then Kill sArchiv ' Jetzt alle Dateien nacheinander in die ' Archivdatei speichern F = FreeFile Open sArchiv For Binary As #F ' Anzahl enthaltener Dateien Put #F, , nFiles For I = 1 To nFiles ' Dateiname speichern nLenFileName = Len(File(I)) Put #F, , nLenFileName Put #F, , File(I) ' Datei-Inhalt einlesen N = FreeFile Open sPath + File(I) For Binary As #N FileData = Space$(LOF(N)) Get #N, , FileData Close #N ' Datei-Inhalt in Archivdatei speichern nLenFileData = Len(FileData) Put #F, , nLenFileData Put #F, , FileData Next I Close #F SaveFilesToArchiv = nFiles End Sub Entpacken der Dateien aus der Archivdatei ' Alle Dateien aus dem Archiv extrahieren und in ' "sDestDir" speichern Public Function ExtractFilesFromArchiv( _ ByVal sArchiv As String, _ ByVal sDestDir As String) As Long Dim F As Integer Dim N As Integer Dim nLenFileName As Integer Dim nLenFileData As Long Dim DirName As String Dim FileData As String Dim File As String Dim nFiles As Long Dim I As Long ' Prüfen, ob Archiv-Datei vorhanden If Dir(sArchiv) = "" Then MsgBox "Das Archiv existiert nicht!", 16 Exit Function End If ' gf. abschliessenden Backslash anfügen If Right$(sDestDir, 1) <> "\" Then _ sDestDir = sDestDir + "\" ' Archiv öffnen F = FreeFile Open sArchiv For Binary As #F ' Anzahl enthaltener Icons Get #F, , nFiles For I = 1 To nFiles ' Original-Dateinamen ermitteln Get #F, , nLenFileName File = Space$(nLenFileName) Get #F, , File ' Datei-Inhalt lesen Get #F, , nLenFileData FileData = Space$(nLenFileData) Get #F, , FileData ' Datei in "DestDir" speichern N = FreeFile Open sDestDir + File For Output As #N Print #N, FileData; Close #N Next I Close #F ExtractFilesFromArchiv = nFiles End Function Und so werden die beiden Funktionen aufgerufen: ' Dateien in Archiv packen Dim nCount As Long nCount = SaveFilesToArchiv("c:\temp\*.ico", _ "f:\my-icons.dat" MsgBox nCount & " Dateien in Archivdatei gespeichert." ' Dateien aus Archiv-Datei entpacken Dim nCount As Long ncount = ExtractFilesFromArchiv("f:\my-icons.dat", _ "d:\temp") MsgBox nCount & " Dateien extrahiert." |