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 m 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 + "\"
 
 
  'erstes Verzeichniss reinschreiben
  lstvorhanden.AddItem sPath
  'Alle Ordner ermitteln
  GetAllFolders (sPath)
 
  ' Dateien im Verzeichnis ermitteln
  nFiles = 0
For m = 0 To lstvorhanden.ListCount - 1
  DirName = Dir(lstvorhanden.List(m) & 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) = lstvorhanden.List(m) & DirName
    End If
    DirName = Dir
  Wend
  ReDim Preserve File(nFiles)
Next m
 
  ' 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
    'Text2.Text = Right(Text2.Text, Len(Text2.Text) - Len(Text1.Text))
    nLenFileName = Len(File(I)) - Len(sPath)
    Put #F, , nLenFileName
    Put #F, , Right(File(I), Len(File(I)) - Len(sPath))
 
    ' Datei-Inhalt einlesen
    N = FreeFile
    Open 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 Function

---------
Lasst es nicht soweit kommen: http://www.againsttcpa.com