Syncing Excel Worksheet to Active Directory

ramsabi 

Syncing Excel Worksheet to Active Directory

Adjust or synchronize a directory including subdirectories via VBA.

In the end, the content must be completely uniform on both sides.

In the target folder, delete the files / directories that are not the same as the source folder.

In the end, both sides (source and destination) are completely the same.

Source = "D: \ Projects \ Service \ Nikolino \ 2021 \ Mystery \"

Target = "S: \ Backup \ Projects \ Service \ Nikolino \ 2021 \ Mystery \"

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (_
    ByVal DirPath As String) As Long
Private Declare Function CopyFileA Lib "kernel32.dll" (_
    ByVal lpExistingFileName As String, _
    ByVal lpNewFileName As String, _
    ByVal bFailIfExists As Long) As Long

Syncronize Public Sub ()
    Const QUELLE As String = "D: \ Projects \ Service \ Nikolino \ 2021 \ Mystery \"
    Const ZIEL As String = "S: \ Backup \ Projects \ Service \ Nikolino \ 2021 \ Mystery \"
    Dim astrFolders () As String, strFilename As String
    Dim ialngFoldes As Long, lngLen As Long
    Dim objFileSystemObject As Object
    If Dir $ (TARGET, vbDirectory) <> vbNullString Then
        Set objFileSystemObject = CreateObject ("Scripting.FileSystemObject")
        Call objFileSystemObject.DeleteFolder (Left $ (ZIEL, Len (ZIEL) - 1), True)
        Set objFileSystemObject = Nothing
    End If
    lngLen = Len (SOURCE) + 1
    astrFolders = GetFolders (SOURCE)
    For ialngFoldes = LBound (astrFolders) To UBound (astrFolders)
        Call MakeSureDirectoryPathExists (ZIEL & Mid $ (astrFolders (ialngFoldes), lngLen))
    Next
    For ialngFoldes = LBound (astrFolders) To UBound (astrFolders)
        strFilename = Dir $ (astrFolders (ialngFoldes) & "*. *")
        Do Until strFilename = vbNullString
            Call CopyFileA (astrFolders (ialngFoldes) & strFilename, _
                ZIEL & Mid $ (astrFolders (ialngFoldes), lngLen) & strFilename, 0)
            strFilename = 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
    Redim astrFolders (0 To 0)
    astrFolders (0) = pvstrPath
    ialngIndex1 = 1
    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 

I would be happy to know if I could help.

Nikolino

I know I don't know anything (Socrates)

* Kindly Mark and Vote this reply if it helps please, as it will be beneficial to more Community members reading here