Append Personal Address Book "RESOLVED"

[swatty]

Hi , I would like to append all known clients of my clients table to the personal address book in outlook by code.

Can this be done and how.

I make use of the MAPISession object and MAPIMessages object.

For each user which email adress is known i would append it to the PAB (Personal Address Book) if it doesn't exists.

[Ecniv]

Private Sub UserForm_Initialize()
    
    Dim objOutlook As Object ' New Outlook.Application
    Dim objNameSpace As Object 'NameSpace
    Dim objDefFolder As Object 'MAPIFolder
'    Dim objItem As Object 'Items
'    Dim objConItem As Object 'ContactItem
'    Dim objAddressList As Object 'AddressList
'    Dim objAddressEntry As Object 'AddressEntry
    
    Dim lngContacts As Long, lngTemps As Long
    Dim blnLeave As Boolean
    Dim strInputtedLine As String, strSplitted() As String
    
    On Error Resume Next
    
    Me.MousePointer = fmMousePointerHourGlass
    
'---- initialize lists
    lstContacts.Clear
    lstContacts.ColumnCount = 5
    lstContacts.ColumnHeads = False
    lstContacts.ColumnWidths = "134;40;40;0;0"
    
    lstTemplates.Clear
    lstTemplates.ColumnCount = 2
    lstTemplates.ColumnWidths = "100;0"
    
    
'---- Loop through contacts (Assume only one list)
'    lstContacts.AddItem "A N Other"
'    lstContacts.Column(1, lstContacts.ListCount - 1) = "4 The Green"
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNameSpace = objOutlook.GetNamespace("Mapi")
        
    Set objDefFolder = objNameSpace.GetDefaultFolder(10)
 
    For lngContacts = 1 To objDefFolder.Items.Count
        With objDefFolder.Items(lngContacts)
            lstContacts.AddItem
            lstContacts.Column(0, lngContacts - 1) = Nnz(.FullName, "Unknown")
            lstContacts.Column(1, lngContacts - 1) = IIf(Len(Nnz(.HomeAddress, "")) > 0, "Home", "")
            lstContacts.Column(2, lngContacts - 1) = IIf(Len(Nnz(.BusinessAddress, "")) > 0, "Business", "")
            lstContacts.Column(3, lngContacts - 1) = Nnz(.HomeAddress, "")
            lstContacts.Column(4, lngContacts - 1) = Nnz(.BusinessAddress, "")
        End With
    Next
       
    objOutlook.Quit
    Set objOutlook = Nothing
    
    Me.MousePointer = fmMousePointerDefault
    
End Sub

The above I used in a Word application to grab the contacts and put them into a list box on a user form. It worked well, maybe you can use part of this to check the personal contacts..? Not sure if there is a faster way of searching the contacts for email addys already entered... or names...


Vince