Ordner in Outlook synchronisieren (nicht zwischen mehreren Benutzern)

Sub BackupFolderStructure()
    Dim colNewMails As New Collection, folderSource As folder, folderTarget As folder, itm As Object, userprop As Property
    'Quellordner  
    Set folderSource = Application.Session.Stores.Item("Persönlicher Ordner").GetRootFolder.Folders("Posteingang").Folders("Quelle")  
    'Zielordner  
    Set folderTarget = Application.Session.Stores.Item("Persönlicher Ordner").GetRootFolder.Folders("Posteingang").Folders("Ziel")  
    
    parseFolder folderSource, colNewMails, folderTarget
    
    'Archivierte Mails mit Archiv-TAG versehen  
    For Each itm In colNewMails
        If itm.UserProperties.Find("isArchived", True) Is Nothing Then  
            Set userprop = itm.UserProperties.add("isArchived", olYesNo)  
            userprop.Value = True
        Else
            itm.UserProperties.Item("isArchived").Value = True  
        End If
        itm.Save
    Next
End Sub

'Rekursive Prozedur zum Suchen in einer Ordnerstruktur  
Sub parseFolder(ByVal fldr As folder, ByRef colMails As Collection, ByVal fldrTarget As folder)
    'Wenn der Ordner Mailitems enthält  
    If fldr.DefaultItemType = olMailItem Then
        For Each itm In fldr.items
            If itm.UserProperties.Find("isArchived", True) Is Nothing Then  
                'Duplikat der Mail erzeugen und in Zielordner kopieren  
                Set newItem = itm.Copy
                newItem.Move fldrTarget
                'Mail zur Collection hinzufügen  
                colMails.add itm
            End If
        Next
    End If
    'Prozedur ruft sich eslbst für alle Unterordner erneut auf  
    For Each subfolder In fldr.Folders
        On Error Resume Next
        Set newTargetSubFolder = fldrTarget.Folders.add(subfolder.Name)
        If newTargetSubFolder Is Nothing Then
            Set newTargetSubFolder = fldrTarget.Folders(subfolder.Name)
        End If
        parseFolder subfolder, colMails, newTargetSubFolder
    Next
End Sub