Sub PutFieldsInNotes()
    MuckWithFields(True)
End Sub


Sub ClearFieldsFromNotes()
    MuckWithFields(False)
End Sub


Sub MuckWithFields(AddProperties As Boolean)
    Dim objApp As Application
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
    Dim colContacts As Items
    Dim objItem As Object
    Dim strAddress As String
    Dim objProperty As Outlook.UserProperty
    Dim strProperties As String
        
    Set objApp = CreateObject("Outlook.Application")
    Set objNS = objApp.GetNamespace("MAPI")
    Set objFolder = objNS.GetDefaultFolder(olFolderContacts)
    If Not objFolder Is Nothing Then
        Set colContacts = objFolder.Items
        For Each objItem In colContacts
            If objItem.Class = olContact Then
                objItem.Body = CleanUpBody(objItem.Body)
                If AddProperties Then
                    strProperties = "User-defined properties:"
                    For Each objProperty In objItem.UserProperties
                        With objProperty
                            strProperties = strProperties & _
                                            vbNewLine & _
                                            .Name & _
                                            Repeat(vbTab, 4 - (Len(.Name) + 2) \ 5) & _
                                            .Value
                        End With
                    Next
                    If objItem.Body <> "" And strProperties <> "" Then
                        objItem.Body = objItem.Body & _
                                       vbNewLine & _
                                       vbNewLine & _
                                       strProperties
                    Else
                        objItem.Body = strProperties
                    End If
                End If
            End If
        objItem.Save
        Next
    End If
    
    Set objItem = Nothing
    Set colContacts = Nothing
    Set objFolder = Nothing
    Set objNS = Nothing
    Set objApp = Nothing
End Sub


Function Repeat(str As String, num As Integer)
    Dim i
    For i = 0 To num
        Repeat = Repeat & str
    Next
End Function


Function CleanUpBody(Body As String)
    Select Case InStr(Body, "User-defined properties:") 
    Case 0
        CleanUpBody = Body
    Case 1
        CleanUpBody = ""
    Case Else
        CleanUpBody = Left(Body, InStr(Body, "User-defined properties:") - 5)
    End Select
End Function