Option Explicit
 
Private Declare Function ShellExecute Lib "shell32.dll" _
            Alias "ShellExecuteA" (ByVal hWnd As Long, _
            ByVal lpOperation As String, ByVal lpFile As String, _
            ByVal lpParameters As String, _
            ByVal lpDirectory As String, ByVal nShowCmd As Long _
            ) As Long
 
Private Type FileDirCount
    iFileCount          As Long
    k                   As Long
    iDirCount           As Long
    n                   As Long
End Type
 
Private Type FileDirArray
    arrFolder()         As String
    arrFile()           As String
End Type
 
Private Const BackSlash As String = "\"
Private Const AllFiles  As String = "\*.*"
Private Const OneDot    As String = "."
Private Const TwoDot    As String = ".."
 
Private Enum ZeroValue
    lZeroValue = 0
End Enum
 
Private blFileRes       As Boolean
Dim fPath As String

 
Private Sub sCopyFolder(sFolderSource As String, _
                           sFolderDestination As String)
 
    Dim fdc             As FileDirCount
    Dim fda             As FileDirArray
    Dim sRes            As String
 
    fdc.iDirCount = ZeroValue.lZeroValue
    fdc.iFileCount = ZeroValue.lZeroValue
 
    blFileRes = False
 
    On Error Resume Next
 
    If Not Err = ZeroValue.lZeroValue Then Exit Sub
        ChDir (sFolderSource)
 
        If Not Err = ZeroValue.lZeroValue Then Exit Sub
 
             If Not Err = ZeroValue.lZeroValue Then Exit Sub
                    ChDir (sFolderDestination)
 
                    If Not Err = ZeroValue.lZeroValue Then
                    Err = ZeroValue.lZeroValue
                    MkDir (sFolderDestination)
 
                    If Not Err = 0 Then Exit Sub
    End If
    On Error GoTo 0
    sRes = Dir((sFolderSource & AllFiles), vbDirectory)
    Do
        If (sRes = OneDot Or sRes = TwoDot) = False Then
            Exit Do
        Else
            sRes = Dir()
        End If
    Loop
 
    Do
    If sRes = vbNullString Then Exit Do
 
        If (GetAttr(sFolderSource & BackSlash & sRes)) = vbDirectory Then
            fdc.iDirCount = fdc.iDirCount + 1
            ReDim Preserve fda.arrFolder(fdc.iDirCount)
            fda.arrFolder(fdc.iDirCount) = sRes
        Else
            fdc.iFileCount = fdc.iFileCount + 1
            ReDim Preserve fda.arrFile(fdc.iFileCount)
            fda.arrFile(fdc.iFileCount) = sRes
        End If
        sRes = Dir()
    Loop
 
    For fdc.n = 1 To fdc.iDirCount
        Call sCopyFolder(sFolderSource & BackSlash & _
                        fda.arrFolder(fdc.n), _
                        (sFolderDestination & BackSlash & _
                        fda.arrFolder(fdc.n)))
        If blFileRes = False Then Exit Sub
    Next
 
    For fdc.k = 1 To fdc.iFileCount
        FileCopy (sFolderSource & BackSlash & _
                        fda.arrFile(fdc.k)), _
                        (sFolderDestination & BackSlash & _
                        fda.arrFile(fdc.k))
    Next
 
    blFileRes = True
 
End Sub

 
'Quell-Ordner-Name extrahieren
Function fFileName(sPath As String) As String
    Dim iCount As Integer
    For iCount = Len(sPath) To 1 Step -1
        If Mid$(sPath, iCount, 1) = "\" Then Exit For
    Next
    fFileName = Right$(sPath, Len(sPath) - iCount)
End Function

 
'Ziel-Verzeichnis erstellen.
Private Function fMakeDir(sNewDir As String) As Integer
    On Error Resume Next
    MkDir sNewDir
    If Err Then
        fMakeDir = False
        MsgBox "Ordner bereits vorhanden"
    Else
        fMakeDir = True
    End If
End Function

 
Private Sub Command1_Click(Index As Integer)
    Select Case Index
        Case Is = 0
           fPath = fFileName(Text1.Text)
           fMakeDir Text2.Text + BackSlash + fPath
           Call sCopyFolder(Text1, Text2 + BackSlash + fPath)
        Case Is = 1: Unload Me
    End Select
    Unload Me
End Sub

 
Private Sub Command2_Click()
  Dim Ordner As String
 
  Ordner = BrowseForFolder("Quell-Ordner")
  If Ordner <> "" Then
    Text1.Text = Ordner
  End If
End Sub

 
Private Sub Command3_Click()
  Dim Ordner As String
 
  Ordner = BrowseForFolder("Ziel-Ordner")
  If Ordner <> "" Then
    Text2.Text = Ordner
  End If
 

End Sub