Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0579: Mehrere Dateien in einer archivieren

VB 5/6-Tipp 0579: Mehrere Dateien in einer archivieren

 von Simon Taddiken

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [4,78 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "cmdExtractIt"
' Steuerelement: Schaltfläche "cmdPackIt"
Option Explicit

' VORSICHT:
' Dieser Tipp zeigt eine /sehr einfache/ Möglichkeit, eine Art
' Dateiarchiv zu erstellen. Das ist für kleine Dateipakete
' durchaus ausreichend, aber sobald es entweder sehr viele
' oder sehr grosse Dateien sind, sollte man sie niemals
' alle gleichzeitig im RAM ablegen müssen!

' Gepackt werden bei diesem Beispiel die Dateien
' "bild.bmp" und "textdatei.txt" im Programmordner.

Private Type PackFile           ' Type für die einzelnen Dateien
    FileName As String          ' Hier steht der Dateiname der Datei
    Contents As String          ' Hier der Inhalt
End Type

Private Type myPack             ' Type für die gepackte Datei
    Files() As PackFile         ' Ein Array für die Dateien
    UBoundFiles As Long         ' und die Obergrenze des Array
End Type

Private APath As String

Private Sub cmdPackIt_Click()
    Dim Files(1) As String      ' Wir haben 2 Dateien zum packen
    
    Files(0) = APath & "textdatei.txt"
    Files(1) = APath & "bild.bmp"
    
    Call PackIt(Files(), APath & "gepackt.sz")
End Sub

Private Sub cmdExtractIt_Click()
    Call ExtractIt(APath & "gepackt.sz", APath)
End Sub

' Funktion zum Packen
Private Function PackIt(Files() As String, DestFile As String)
    Dim i As Long
    Dim FN As Integer
    Dim zw As String
    Dim Pack As myPack
    
    Me.MousePointer = vbHourglass
    
    Pack.UBoundFiles = UBound(Files)        ' Anzahl der Files
    ReDim Pack.Files(Pack.UBoundFiles)
    
    For i = 0 To UBound(Files())
        FN = FreeFile
        Open Files(i) For Binary As #FN     ' Einzelne Dateien öffnen,
        
        zw = Space(LOF(FN))                 ' String vordimensionieren,
        Get #FN, , zw                       ' einlesen,
        Pack.Files(i).Contents = zw         ' Inhalt in den UDT packen,
        Pack.Files(i).FileName = Files(i)   ' den FileNamen ebenfalls
        
        Close #FN
    Next i
    
    FN = FreeFile
    Open DestFile For Binary As #FN         ' Ziel Datei öffnen
    
    Put #FN, , Pack                         ' und den UDT speichern
    
    Close #FN
    
    Me.MousePointer = vbDefault
End Function

'Funktion zum entpacken
Private Function ExtractIt(Source As String, DestPath As String)
    Dim i As Long
    Dim FN As Long
    Dim UBF As Long
    Dim Pack As myPack
    
    FN = FreeFile
    Open Source For Binary As #FN           ' Gepackte Datei öffnen,
    
    Get #FN, LOF(FN) - 3, UBF               ' Anzahl der Files auslesen,
    
    Close
    
    ReDim Pack.Files(UBF)                   ' UDT dimensionieren,
    
    Open Source For Binary As #FN
    
    Get #FN, , Pack                         ' Inhalt in den UDT
    
    Close
    
    For i = 0 To UBF                        ' Einzelne Dateien,
        FN = FreeFile
        Open DestPath & GetFileName(Pack.Files(i).FileName) _
          For Binary As #FN                 ' öffnen/erstellen,
        
        Put #FN, , Pack.Files(i).Contents   ' Inhalt speichern
        
        Close #FN
    Next i
End Function

'Funktion um den Dateinamen aus dem Pfad zu "extrahieren"
Private Function GetFileName(xFile As String) As String
    Dim lastbs As Long          ' Position des letzten Backslashes (\)
    
    lastbs = InStrRev(xFile, "\")
    GetFileName = Mid(xFile, lastbs + 1)
End Function


Private Sub Form_Load()
    APath = App.Path & IIf(Right(App.Path, 1) = "\", "", "\")
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 5 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.