AW: Dateioperationen:
18.08.2020 16:08:01
Nepumuk
Hallo Gerald,
teste mal:
Option Explicit
Private Declare PtrSafe Function CopyFileA Lib "kernel32.dll" ( _
ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Public Sub Gerald()
Const FOLDER_PATH_1 As String = "C:\source\"
Const FOLDER_PATH_2 As String = "C:\compare\"
Const FOLDER_PATH_3 As String = "C:\destination\"
Dim objDictionary_1 As Object, objDictionary_2 As Object
Dim adtmFileDate() As Date
Dim astrFolders() As String, strFilename As String
Dim ialngFolders As Long, ialngFileDate As Long
Dim vntItem As Variant
Set objDictionary_1 = CreateObject(Class:="Scripting.Dictionary")
astrFolders = GetFolders(FOLDER_PATH_1)
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
strFilename = Dir$(PathName:=astrFolders(ialngFolders) & "*.*")
Do Until strFilename = vbNullString
If Not objDictionary_1.Exists(Key:=strFilename) Then _
Call objDictionary_1.Add(Key:=strFilename, Item:=astrFolders(ialngFolders) & strFilename)
strFilename = Dir$
Loop
Next
Set objDictionary_2 = CreateObject(Class:="Scripting.Dictionary")
astrFolders = GetFolders(FOLDER_PATH_2)
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
strFilename = Dir$(PathName:=astrFolders(ialngFolders) & "*.*")
Do Until strFilename = vbNullString
If Not objDictionary_2.Exists(Key:=strFilename) Then
Call objDictionary_2.Add(Key:=strFilename, Item:=ialngFileDate)
Redim Preserve adtmFileDate(ialngFileDate)
adtmFileDate(ialngFileDate) = FileDateTime(PathName:=astrFolders(ialngFolders) & strFilename)
ialngFileDate = ialngFileDate + 1
Else
If FileDateTime(PathName:=astrFolders(ialngFolders) & strFilename) > _
adtmFileDate(objDictionary_2.Item(Key:=strFilename)) Then _
adtmFileDate(objDictionary_2.Item(Key:=strFilename)) = _
FileDateTime(PathName:=astrFolders(ialngFolders) & strFilename)
End If
strFilename = Dir$
Loop
Next
For Each vntItem In objDictionary_1.Keys
If objDictionary_2.Exists(Key:=vntItem) Then
If FileDateTime(PathName:=objDictionary_1.Item(Key:=vntItem)) > _
adtmFileDate(objDictionary_2.Item(Key:=vntItem)) Then _
Call CopyFileA(objDictionary_1.Item(Key:=vntItem), FOLDER_PATH_3 & vntItem, 0)
Else
Call CopyFileA(objDictionary_1.Item(Key:=vntItem), FOLDER_PATH_3 & vntItem, 0)
End If
Next
Set objDictionary_1 = Nothing
Set objDictionary_2 = Nothing
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
Redim Preserve astrFolders(ialngIndex1)
astrFolders(ialngIndex1) = pvstrPath
ialngIndex1 = 1
ialngIndex2 = 1
strPath = pvstrPath
Do
strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
Do Until strFolder = vbNullString
If strFolder <> "." And strFolder <> ".." Then
If GetAttr(PathName:=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