AW: Robocopy
29.10.2017 19:25:35
Nepumuk
Hallo Bernd,
teste mal:
Option Explicit
Public Sub test()
Const SOURCE_PATH As String = "H:\Beispiel\"
Const TARGET_PATH As String = "H:\Hierher\"
Dim astrFolders() As String, strFile As String
Dim ialngIndex As Long
astrFolders = GetFolders(SOURCE_PATH)
For ialngIndex = LBound(astrFolders) To UBound(astrFolders)
strFile = Dir$(astrFolders(ialngIndex) & "*.*")
Do Until strFile = vbNullString
FileCopy astrFolders(ialngIndex) & strFile, TARGET_PATH & strFile
strFile = Dir$
Loop
Next
End Sub
Private Function GetFolders(ByVal pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
strPath = pvstrPath
Do
strFolder = Dir$(strPath & "*", vbDirectory)
Do Until strFolder = vbNullString
If strFolder <> "." And strFolder <> ".." Then
If GetAttr(strPath & strFolder) And vbDirectory Then
Redim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function
Gruß
Nepumuk