Verzeichnis kopieren
Mit der bekannten API-Funktionen ShellExecute und einigen Tricks lassen sich Ordner nach jeder beliebigen Stelle kopieren. Zuerst wird der Name des ausgewählten Ordners extrahiert, dann ein neuer Ordner mit diesem Namen an der gewünschten Stelle erzeugt. Anschließend der Inhalt des Quell-Ordners mit samt allen Unterordnern in den neuen Ordner kopiert. Fertig!
Laden Sie sich die Zip-Datei mit VB 6 Source Code hinunter und probieren Sie es mal aus.

Projekt - Download
© FienauBerlin   Web-ComputerEcke.de
 

Quell-Code
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