Solved Export All Access Contacts to Outlook

[dgreen]

Things are working. I'm playing around with the code now. I'll post an updated code later today.

Need to track when the user clicked the button so we know what's changed in the database since then (existing records modified and new ones added). Using a INSERT to track that by FOSUserName.

Don't error and stop when uploading. Skip to the next record. With the above, then we can figure out which records didn't load and troubleshoot. Thinking of having a query that shows what didn't load.

Then maybe the button's data source points to changes since last refresh, vice the entire data source.

This then leads to figuring out the best way to handle existing records that have changed in access but are already in Outlook. Do we delete them out and replace them (assumes Access db knows it all), open them up one at a time and resolve individually (assumes that Outlook record might have information that the user is tracking that the database isn't)?

 

[Dreamweaver]

You can edit an entry in outlook as you have the CustomerID It should be easy

 

[dgreen]

If you have the time, can you find the code to do so?

You can edit an entry in outlook as you have the CustomerID It should be easy

 

[Dreamweaver]

If you have the time, can you find the code to do so?

You already have a lot of what you need I would let google do the work

I Lost that part of my outlook modules and have not had the need to recreate them sorry.

 

[dgreen]

For my list of 750+ people and the data being stored on SharePoint it took ~1-2 seconds, per record, to load the contact's data along with picture.
While there are a couple of gaps, the below code extracts from an Access database contacts, imports them into Outlook and tracks that the record was passed (INSERT), based on the button in the upper left (Export All Contacts).

What shows up in Outlook (blue values populated - hidden for privacy reasons)

The fact that the data was loaded is tracked in another table, stored by individual user (since each of us can click this on our own laptops.

If the record already exists in Outlook (primary key in Access is Name_ID, an autonumber), this code skips to the next Contact.
This code doesn't have a means to handle changed data in Access getting pushed into Outlook, for a Contact that already exists.

Option Compare Database
Option Explicit
Private Sub ExportAccessContacts_Click()
    Dim OlApp As Object
    Dim olContact As Object
    On Error GoTo HandleErr

    Const olContactItem = 2

    Set OlApp = CreateObject("Outlook.Application")

    Dim appOutlook As Outlook.Application
    Dim nms As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object
    Dim con As Outlook.ContactItem
    Dim lngContactID As Long

    Dim ClickResult As VbMsgBoxResultEx
    Dim strFile As String

    Dim rst As Dao.Recordset
    Set rst = CurrentDb.OpenRecordset("q_Contacts_Search", dbOpenSnapshot)

    Set appOutlook = GetObject(, "Outlook.Application")
    Set nms = appOutlook.GetNamespace("MAPI")
    Set fld = nms.GetDefaultFolder(olFolderContacts)

    'Move to the first record in the table/query
    rst.MoveFirst

    'Continue to do the below loop untill all records are either added to Outlook or have been confirmed that they were already there.
    Do Until rst.EOF
    
        lngContactID = rst("Name_ID")
        strFile = "C:\Users\" & fOSUserName() & "\Pictures\Contacts\" & rst("First_Name") & " " & rst("Last_Name") & ".png"
        Set con = fld.Items.Find("[CustomerID] = " & lngContactID)
        Set olContact = OlApp.CreateItem(olContactItem)
    
        If Not TypeName(con) = "Nothing" Then
            rst.MoveNext
        Else
            With olContact
            
                .CustomerID = rst("Name_ID")
                .FirstName = Nz(rst("First_Name"), "")
                .MiddleName = Nz(rst("MI"), "")
                .LastName = rst("Last_Name")
                .FullName = rst("FullName")
                .FileAs = rst("FullName")
                If IsNull(rst("Work_Anniversary")) = False Then
                    .Anniversary = Format(rst("Work_Anniversary"), "dd/mm/yyyy")
                End If
                If IsNull(rst("Birthday")) = False Then
                    .Birthday = Format(rst("Birthday"), "mm/dd/yyyy") 'formatted differently so that it exported the medium date format correctly, because I'm not showing the users the year.
                End If
                .CompanyName = Nz(DLookup("[Organization]", "[q_Organizations_Search]", "[ORG_Child_ID]=" & Nz(rst("Org_Child_ID"), 0)), "")
                .JobTitle = Nz(rst("JobTitle"), "")
                .BusinessAddressStreet = Nz(rst("Address"), "")
                .BusinessAddressCity = Nz(rst("City"), "")
                .BusinessAddressState = Nz(rst("State"), "")
                .BusinessAddressCountry = Nz(DLookup("[Country]", "[t_Country]", "[Country_Auto]=" & Nz(rst("Country"), 0)), "")
                .BusinessAddressPostalCode = Nz(rst("ZIP_Postal_Code"), "")
                .BusinessTelephoneNumber = Nz(Format(rst("Business_Phone"), "(###)###-####"), "")
                .MobileTelephoneNumber = Nz(Format(rst("Mobile_Phone"), "(###)###-####"), "")
                .Email1Address = Nz(rst("Email_Address"), "")
                .Email2Address = Nz(rst("Other_Email"), "")
                'Need to remove rich text so <DIV and other fomatting don't come over.  Need to figure out how to remove extra enters.
                .Body = Nz(PlainText(rst("Notes")), "") & vbCrLf & "Skype: " & Nz(rst("Skype"), "")
                '.WebPage = Nz(rst("Web_Page"), "")
                .ManagerName = Nz(DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Nz(rst("Manager_Name_ID"), 0)), "")
                .AssistantName = Nz(DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Nz(rst("Assistant_Name_ID"), 0)), "")
                If Dir(strFile) <> "" Then
                    .AddPicture (strFile)
                End If
                .Save
            End With
            'Track that the button was clicked.
            Dim Action As String
            Action = "Mass uploaded to Outlook"
        
            CurrentDb.Execute "INSERT INTO t_User_Outlook_Contacts_Loaded ([UserName],[Name_ID], [Action]) Values (fosusername(),'" & rst("Name_ID") & "', '" & [Action] & "')"
            'Move to the next record
            rst.MoveNext
            'Start over again with the next record in the table/query
        End If
    Loop
    'clean up
    Set olContact = Nothing
    Set con = Nothing
    Set fld = Nothing
    Set nms = Nothing
    Set appOutlook = Nothing

    rst.Close
    Set rst = Nothing

    MsgBox "Done"

HandleExit:
    Exit Sub

HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox Err.Number & vbCrLf & Err.Description
            Resume HandleExit
            Resume
    End Select
End Sub

Thanks to the team for helping me get this far. If others have thoughts on my gaps feel free to comment below.

 

[bastanu]

You can you try to link the Outlook contacts into your db and run a query that would compare the two sources.

Cheers,
Vlad

 

[dgreen]

I'm trying to have a solution that works for each user of the database and all of their personal Outlook accounts.

 

[bastanu]

So you could then import them in a local table in the front end and open a form that compares them side by side (Access data vs. Outlook). If you have a relatively small number of fields that you want to compare it should be easy to build a query to capture the differences (using <>[tblOutlook].[Field] on different Or rows in the criteria).

 

[dgreen]

Outlook
Edit an Account

Edit an Account [Business Contact Manager for Outlook Developer Reference]

docs.microsoft.com