Option Explicit
Public Sub Kopiere(Quelle As String, Ziel As String)
On Error GoTo Kopiere_ErrorHandler
Const pufflen = 4095
Dim RestLen As Long
Dim puffer() As Byte
Dim Laenge As Long
Dim rest As Single
ReDim puffer(pufflen)
Open Quelle For Binary Access Read As #1
Open Ziel For Binary Access Write As #2
Laenge = LOF(1)
Do Until Seek(1) > Laenge
RestLen = Laenge - Seek(1)
If RestLen < pufflen Then ReDim puffer(RestLen)
Get #1, , puffer
Put #2, , puffer
rest = 100 * (Seek(1) / (Laenge + 1))
    Me.Caption = CLng(Seek(1) / 1024) & _
                " KBytes Kopiert von " & CLng(Laenge / 1024) & _
                "  :" & Format(rest, "###0.00") & "%"
    Me.Refresh
  Loop
  Close #1
  Close #2
Exit Sub
Kopiere_ErrorHandler:
  MsgBox (Err.Description)
  Close #1
  Close #2
End Sub
 
Private Sub Command1_Click()
    Dim Datei1, Pfad1, Name1
Pfad1 = "d:\meinequelle\"   ' Pfad setzen.
Name1 = Dir(Pfad1, vbNormal)   ' Ersten Eintrag abrufen.
Do While Name1 <> ""   ' Schleife beginnen.
   ' Aktuelles und übergeordnetes Verzeichnis ignorieren.
   If Name1 <> "." And Name1 <> ".." Then
      ' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein
      ' Verzeichnis ist.
      If (GetAttr(Pfad1 & Name1) And vbNormal) = vbNormal Then
         Debug.Print Name1   ' Eintrag nur anzeigen, wenn es sich
      End If   ' um ein Verzeichnis handelt.
   End If
   Name1 = Dir   ' Nächsten Eintrag abrufen.
Kopiere "Name1", "c:\meinziel\"
 
Loop
 
    End Sub