Sub Start()
  If StartMerker = True Then Exit Sub
  StartMerker = True
  lblInfo.Caption = "Info" & vbCrLf
  Select Case Command
    Case "All"
      Dim i As Integer
      For i = 0 To 3
        cmdKopieren_Click i
        lblInfo.Caption = lblInfo.Caption & Choose(i, "Eigene Dateien", "Eigene" & _
          "Webs", "Outlook oben", "Lexware") & " (" & BaumKopieren.Anzahl & ")" & _
          "fertig" & vbCrLf
      Next
      MsgBox "Fertig: " & BaumKopieren.Anzahl & " Verzeichnisse kopiert"
    Case Else
  End Select
End Sub
Private Sub cmdKopieren_Click(Index As Integer)
      'Ordner "d:\temp" mit allen Unterordnern und Dateien nach "e:\temp" 
      ' kopieren
      'DirCopy "d:\temp", "e:\temp"
  Select Case Index
    Case 0
      BaumKopieren.DirCopy "G:\Eigene Dateien", "I:\Eigene Dateien"
    Case 1
      BaumKopieren.DirCopy "G:\Eigene Webs", "I:\Eigene Webs"
    Case 2
      BaumKopieren.DirCopy "G:\Outlook Express", "I:\Outlook Express"
    Case 3
      BaumKopieren.DirCopy "E:\Programme\Lexware", "I:\Lexware"
  End Select
End Sub

Option Explicit
Public Anzahl As Long
' Ordner inkl. aller Dateien und Unterordner kopieren
Public Function DirCopy(ByVal sDir As String, _
  ByVal dDir As String)
 
  Dim dcV As Variant, dcI As Integer
 
  On Error Resume Next
 
  ' zunächst alle Dateien ermitteln
  If sDir = dDir Then Exit Function
  dcV = ReadFilesFromDir(sDir)
 
  ' Ziel-Verzeichnis erstellen
  MkDir dDir
 
  ' alle Dateien kopieren
  For dcI = 0 To UBound(dcV)
    FileCopy sDir & "\" & dcV(dcI), dDir & "\" & dcV(dcI)
    AddAnzahl
  Next dcI
 
  ' Jetzt alle Unterordner ermitteln und Dateien kopieren
  dcV = ReadDirs(sDir)
  For dcI = 0 To UBound(dcV)
    ' Es kann vorkommen, dass jemand den Ordner in sich
    ' selbst kopieren will - was eine Endlosschleife gäbe:
    If dcV(dcI) = "" Then Exit For
 
    ' Ziel-Unterordner erstellen:
    MkDir dDir & "\" & dcV(dcI)
 
    ' Rekursiver Funktionsaufruf, um den Unterordner
    ' zu erstellen und die Dateien zu kopieren
    DirCopy sDir & "\" & dcV(dcI), dDir & "\" & dcV(dcI)
  Next dcI
End Function
' Funktion um alle Dateien eines Ordner zu ermitteln
Private Function ReadFilesFromDir(ByVal sPath As String, _
  Optional sFilter As String = "*.*") As Variant
 
  Dim sFilename As String
  Dim nCount As Long
  ReDim sFiles(0) As String
 
  If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
  nCount = 0
  sFilename = Dir(sPath & sFilter, vbNormal)
  While sFilename <> ""
    If sFilename <> "." And sFilename <> ".." Then
      ReDim Preserve sFiles(nCount)
      sFiles(nCount) = sFilename
      nCount = nCount + 1
    End If
    sFilename = Dir
  Wend
 
  ReadFilesFromDir = sFiles
End Function
' Funktion, um alle Ordner einer Ebene zu ermitteln
Private Function ReadDirs(ByVal sPath As String) As Variant
  Dim sFilename As String
  Dim nCount As Long
  ReDim sFiles(0) As String
 
  If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
  nCount = 0
  sFilename = Dir(sPath, vbDirectory)
  While sFilename <> ""
    If sFilename <> "." And sFilename <> ".." And _
      GetAttr(sPath & "\" & sFilename) = vbDirectory Then
 
      ReDim Preserve sFiles(nCount)
      sFiles(nCount) = sFilename
      nCount = nCount + 1
    End If
    sFilename = Dir
  Wend
 
  ReadDirs = sFiles
End Function
Sub AddAnzahl()
  DoEvents
  Anzahl = Anzahl + 1
  Hauptform.lblAnzahlKopiert = Anzahl
End Sub