vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
SEPA-Dateien erstellen inkl. IBAN-, BLZ-/Kontonummernprüfung  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Dateisystem · Dateien allgemein   |   VB-Versionen: VB608.07.03
Dateien verpacken und extrahieren

Tipp, wie man einfach mehrere Dateien in eine packt und diese wieder ausliest.

Autor:   Sascha KurthBewertung:     [ Jetzt bewerten ]Views:  17.871 
ohne HomepageSystem:  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

Dieser Tipp wurde bereits 17.871 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel