Benutzerdefinierte Ordnerfelder im Outlook ex- und importieren

Sub MigrateCustomUserProperties()
    Dim objStoreTarget As Store, objStoreSource As Store
    'Quellstore wählen  
    MsgBox "Wählen sie im folgenden Dialog einen Quellstore aus welcher die benutzerdefinierten Felder beinhaltet.", vbInformation  
    Set objStoreSource = Application.Session.PickFolder.Store
    ' Zielstore wählen  
    MsgBox "Wählen sie nun einen Zielstore zum Übertragen der benutzerdefinierten Felder aus.", vbInformation  
    Set objStoreTarget = Application.Session.PickFolder.Store
    
    'rekursive Prozedur starten  
    processFolders objStoreSource.GetRootFolder, objStoreTarget.GetRootFolder
    
    msgbox "Migration abgeschlossen."  
End Sub

Sub processFolders(ByVal fldr As Folder, ByRef objTargetRoot As Folder)
    On Error Resume Next
    Dim prop As UserDefinedProperty, objTargetFolder As Folder, found As Boolean
    found = True
    'Anfang für die Ordnerrekutrsion  
    Set objTargetFolder = objTargetRoot
    'Pfad ohne Storenamen erstellen  
    strFullPath = Split(fldr.FolderPath, "\", 4, 1)(3)  
    ' Navigiere zum Zielordner über einen Split des Pfades durch '\'  
    For Each strPathPart In Split(strFullPath, "\", -1, 1)  
        Set objTargetFolder = objTargetFolder.Folders(strPathPart)
        If Err.number <> 0 Then
            ' Wenn Pfad nicht existiert verarbeite stattdessen den nächsten Ordner  
            found = False
            Exit For
        End If
    Next
    ' Existiert der gleiche Ordner auch im Zielstore, dann ...  
    If found Then
        'Für jede benutzerdefinierte Eigenschaft des Ordners  
        For Each prop In fldr.UserDefinedProperties
            'Wenn die Eigenschaft im Zielstore noch nicht existiert, lege sie mit den selben Eigenschaften dort an  
            If objTargetFolder.UserDefinedProperties.Find(prop.Name) Is Nothing Then
                objTargetFolder.UserDefinedProperties.Add prop.Name, prop.Type, prop.DisplayFormat, prop.Formula
            End If
        Next
    End If
    'Für jeden Unterordner Funktion rekursiv aufrufen  
    For Each subfolder In fldr.Folders
        processFolders subfolder, objTargetRoot
    Next
End Sub