Outlook VBS para adicionar o endereço SMTP do EX (x.500) para a propriedade ContactItem.User1

Question

Primeiro, quero advertir que pesquisei este e tentei uma tonelada de soluções aqui e em outros lugares. Peço desculpas se isso já foi respondido, eu juro que olhei e tentei, mas o principal problema que tenho é que eu tenho a habilidade VB de um chimpanzé, e acho que a solução requer pelo menos um nível de habilidade VB do Bonobo. / p>

Estou tentando criar um script VB no Outlook que passe pelas minhas pastas de contatos padrão e observe os e-mails de cada contato .Email1Address e converta o "EX" Email1AddressType em uma string e grave-o na propriedade .User1.

O objetivo é poder sempre exportar do Outlook os endereços SMTP dos meus contatos que são armazenados como "EX" quando eu os adiciono da GAL.

Acho que estou fora do alvo aqui, e qualquer ajuda seria apreciada. Muito obrigado:

Public Sub User1SMTPAddress()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objContact As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim objContactsFolder As Outlook.MAPIFolder
Dim oExUser As Outlook.ExchangeUser
Dim obj As Object
Dim SMTPEmailAddress As String
Dim MyContactID As String 
Dim oPA As Outlook.PropertyAccessor

On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
Set objItems = objContactsFolder.Items

For Each obj In objItems
    If obj.Class = olContact Then
        Set objContact = obj

        With objContact

            Set oPA = objContact.PropertyAccessor
            MyContactID = oPA.BinaryToString_(oPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C190102"))
            Set oSender = Globals.objNS.GetAddressEntryFromID(MyContactID)
            oExUser = oSender.GetExchangeUser()
            SMTPEmailAddress = oExUser.PrimarySmtpAddress
            .User1 = SMTPEmailAddress
            .Save

        End With

    End If

    Err.Clear
Next

Set objOL = Nothing
Set objNS = Nothing
Set obj = Nothing
Set objContact = Nothing
Set objItems = Nothing
Set objContactsFolder = Nothing
End Sub