Solved Export All Access Contacts to Outlook (1 Viewer)

dgreen

Member
Local time
Today, 06:04
Joined
Sep 30, 2018
Messages
396
While I have a way to export a single contact from Access to Outlook, I am finding the need to be able to export the ENTIRE list to a user's Outlook contacts.

I need help with the code that would loop thru all of the records, checking to see if a record exists or not (using CustomerID field) and if no record exists creating the contact. Then after it saves, automatically moving to the next record.

I've cobbled together something (below) but because the code came from a different process to import into Outlook vice export from Access, it doesn't compile past the following section (inumcontacts = objitems.Count).

I've commented where I think I have issues.

Code:
Private Sub ExportAccessContacts_Click()
    On Error GoTo Error_Handler
    Dim OlApp             As Object
    Dim olContact         As Object
    Const olContactItem = 2
    
    'https://docs.microsoft.com/en-us/previous-versions/office/developer/office-2003/aa210907(v=office.11)?redirectedfrom=MSDN
    
    Set OlApp = CreateObject("Outlook.Application")
    Set olContact = OlApp.CreateItem(olContactItem)
    
    'https://office-watch.com/2010/matching-outlook-and-access-contacts/
    'http://www.helenfeddema.com/Access%20Archon.htm
    
    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 i As Integer
    
    lngContactID = Nz(Me.[Name_ID])
    strFile = "C:\Users\" & fOSUserName() & "\Pictures\AVC_Backend\Contacts\" & Me.First_Name & " " & Me.Last_Name & ".png"
    
    Set appOutlook = GetObject(, "Outlook.Application")
    Set nms = appOutlook.GetNamespace("MAPI")
    Set fld = nms.GetDefaultFolder(olFolderContacts)
    Set con = fld.Items.Find("[CustomerID] = " & lngContactID)
    
    'Need something that counts the number of Access records.  I think this isn't right.
    inumcontacts = objitems.Count
    If inumcontact <> 0 Then
        For i = 1 To inumcontacts
        
        'Move to the first record in the table/query
            rst.MoveNext
            '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
            
            If Not TypeName(con) = "Nothing" Then
                'Skip to next contact
                'Need some code to do this
            Else
                'https://docs.microsoft.com/en-us/office/vba/outlook/concepts/forms/outlook-fields-and-equivalent-properties
                With olContact
                    .CustomerID = Me.Name_ID
                    .FirstName = Me.First_Name
                    .MiddleName = Nz(Me.MI, "")
                    .LastName = Me.Last_Name
                    .FullName = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Me.Name_ID)
                    .FileAs = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Me.Name_ID)
                    If IsNull(Me.Work_Anniversary) = False Then
                        .Anniversary = Format(Me.Work_Anniversary, "dd/mm/yyyy")
                    End If
                    If IsNull(Me.Birthday) = False Then
                        .Birthday = Format(Me.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(Me.Org_Child_ID, 0)), "")
                    .JobTitle = Nz(Me.JobTitle, "")
                    .BusinessAddressStreet = Nz(Me.Address, "")
                    .BusinessAddressCity = Nz(Me.City, "")
                    .BusinessAddressState = Nz(Me.State, "")
                    .BusinessAddressCountry = Nz(DLookup("[Country]", "[t_Country]", "[Country_Auto]=" & Nz(Me.Country, 0)), "")
                    .BusinessAddressPostalCode = Nz(Me.ZIP_Postal_Code, "")
                    .BusinessTelephoneNumber = Nz(Format(Me.Business_Phone, "(###)###-####"), "")
                    .MobileTelephoneNumber = Nz(Format(Me.Mobile_Phone, "(###)###-####"), "")
                    .Email1Address = Nz(Me.Email_Address, "")
                    .Email2Address = Nz(Me.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(Notes), "") & vbCrLf & "Skype: " & Nz(Skype, "")
                    .WebPage = Nz(Web_Page, "")
                    .ManagerName = Nz(DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Nz(Me.Manager_Name_ID, 0)), "")
                    .AssistantName = Nz(DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Nz(Me.Assistant_Name_ID, 0)), "")
                    If Dir(strFile) <> "" Then
                        .AddPicture (strFile)
                        .Save
                    'Move to the next record
                    Next i
                    'Do I need this?
                    rst.Close
                    rst.MoveNext
                    'Start over again with the next record in the table/query
                    Loop
                End If
            End With
        End If
        
Error_Handler_Exit:
        On Error Resume Next
        If Not olContact Is Nothing Then Set olContact = Nothing
        If Not OlApp Is Nothing Then Set OlApp = Nothing
        Exit Sub
        
Error_Handler:
        MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: AddOlContact" & vbCrLf & _
               "Error Description: " & Err.Description & _
               Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
               , vbOKOnly + vbCritical, "An Error has Occurred!"
        Resume Error_Handler_Exit
End Sub
 

theDBguy

I’m here to help
Staff member
Local time
Today, 04:04
Joined
Oct 29, 2018
Messages
13,738
Hi. I only quickly scanned your code. To find out how many records in a recordset, if using DAO, you need to issue a MoveLast first and then use the RecordCount property. If not using a recordset, you can use the DCount() function.
 

bastanu

Registered User.
Local time
Today, 04:04
Joined
Apr 13, 2010
Messages
457
There are a few problems with your code. You do not declare and Set the rst (recordset) variable anywhere. Then you need to place everythiing inside the recordset loop starting with lngContactID = Nz(rst("Name_ID") and replace Me. with rst("FieldName").
To loop the recordset you don't need the count,move to the first record then use rst.movenext just before the Loop
Code:
Dim rst as Dao.Recorset
Set rst=CurrentDB.openrecordset("q_Contacts_Search")
rst.MoveFirst
Do Until rst.EOF
    'do your processing here

rst.MoveNext
Loop

Cheers,
Vlad
 

vba_php

Forum Troll
Local time
Today, 06:04
Joined
Oct 6, 2019
Messages
2,884
you know,

instead of writing all that code which would cause you to pull your hair out, are you aware that you can simply export a dataset from access, turn it into a CSV file, and import that into outlook? and BAM, you're done. =) and actually, I believe the outlook program even reads data in other formats outside of CSV. we're not talking about sophistication like JSON or XML, but I believe txt will work too. actually now that I think about it, XML might be accepted. you'd have to check.
 

dgreen

Member
Local time
Today, 06:04
Joined
Sep 30, 2018
Messages
396
I'm bald, so it's already out. I'm tracking the other options available but I like to try and control the environment my user's experience.

instead of writing all that code which would cause you to pull your hair out
 

vba_php

Forum Troll
Local time
Today, 06:04
Joined
Oct 6, 2019
Messages
2,884
I'm bald, so it's already out. I'm tracking the other options available but I like to try and control the environment my user's experience.
it was just an option. As you'll notice there are many different people that respond to virtually every post so you get all types of options available to you in this place
 

dgreen

Member
Local time
Today, 06:04
Joined
Sep 30, 2018
Messages
396
There are a few problems with your code.

Concur. I made the adjustments, running into an issue with the Loop, saying it needs a Do. Also do I need to change the .CustomerID = Me.Name_ID to the rst(Name_ID) below as well or is that part of the code ok?

Code:
    Dim rst As Dao.Recordset
    Set rst = CurrentDb.OpenRecordset("q_Contacts_Search")
    
    lngContactID = Nz(rst([Name_ID]))
    strFile = "C:\Users\" & fOSUserName() & "\Pictures\AVC_Backend\Contacts\" & Me.First_Name & " " & Me.Last_Name & ".png"
    
    Set appOutlook = GetObject(, "Outlook.Application")
    Set nms = appOutlook.GetNamespace("MAPI")
    Set fld = nms.GetDefaultFolder(olFolderContacts)
    Set con = fld.Items.Find("[CustomerID] = " & lngContactID)
    
    'Move to the first record in the table/query
    rst.MoveNext
    '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
        
        If Not TypeName(con) = "Nothing" Then
            'Skip to next contact
            'Need some code to do this
        Else
            'https://docs.microsoft.com/en-us/office/vba/outlook/concepts/forms/outlook-fields-and-equivalent-properties
            With olContact
                .CustomerID = Me.Name_ID
                .FirstName = Me.First_Name
                .MiddleName = Nz(Me.MI, "")
                .LastName = Me.Last_Name
                .FullName = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Me.Name_ID)
                .FileAs = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Me.Name_ID)
                If IsNull(Me.Work_Anniversary) = False Then
                    .Anniversary = Format(Me.Work_Anniversary, "dd/mm/yyyy")
                End If
                If IsNull(Me.Birthday) = False Then
                    .Birthday = Format(Me.Birthday, "mm/dd/yyyy")
                End If
                .CompanyName = Nz(DLookup("[Organization]", "[q_Organizations_Search]", "[ORG_Child_ID]=" & Nz(Me.Org_Child_ID, 0)), "")
                .JobTitle = Nz(Me.JobTitle, "")
                .BusinessAddressStreet = Nz(Me.Address, "")
                .BusinessAddressCity = Nz(Me.City, "")
                .BusinessAddressState = Nz(Me.State, "")
                .BusinessAddressCountry = Nz(DLookup("[Country]", "[t_Country]", "[Country_Auto]=" & Nz(Me.Country, 0)), "")
                .BusinessAddressPostalCode = Nz(Me.ZIP_Postal_Code, "")
                .BusinessTelephoneNumber = Nz(Format(Me.Business_Phone, "(###)###-####"), "")
                .MobileTelephoneNumber = Nz(Format(Me.Mobile_Phone, "(###)###-####"), "")
                .Email1Address = Nz(Me.Email_Address, "")
                .Email2Address = Nz(Me.Other_Email, "")
                .Body = Nz(PlainText(Notes), "") & vbCrLf & "Skype: " & Nz(Skype, "")
                .WebPage = Nz(Web_Page, "")
                .ManagerName = Nz(DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Nz(Me.Manager_Name_ID, 0)), "")
                .AssistantName = Nz(DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Nz(Me.Assistant_Name_ID, 0)), "")
                If Dir(strFile) <> "" Then
                    .AddPicture (strFile)
                    .Save
                    'Move to the next record
                End If
            
            rst.MoveNext
            'Start over again with the next record in the table/query
            Loop
            
        
Error_Handler_Exit:
 

dgreen

Member
Local time
Today, 06:04
Joined
Sep 30, 2018
Messages
396
Nope. I'm passed the Do Loop error. Code Compiles.

New error #13, AddOlContact, Type mismatch.

It error stops at this line (.CustomerID = Me.Name_ID). Hovering over the value it's right for the 1st record. Not sure what the next step to fix is.

Code:
Private Sub ExportAccessContacts_Click()
    On Error GoTo Error_Handler
    Dim OlApp             As Object
    Dim olContact         As Object
    Const olContactItem = 2
    
    Set OlApp = CreateObject("Outlook.Application")
    Set olContact = OlApp.CreateItem(olContactItem)
    
    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")
    
    lngContactID = rst([Name_ID])
    strFile = "C:\Users\" & fOSUserName() & "\Pictures\AVC_Backend\Contacts\" & Me.First_Name & " " & Me.Last_Name & ".png"
    
    Set appOutlook = GetObject(, "Outlook.Application")
    Set nms = appOutlook.GetNamespace("MAPI")
    Set fld = nms.GetDefaultFolder(olFolderContacts)
    Set con = fld.Items.Find("[CustomerID] = " & lngContactID)
    
    'Move to the first record in the table/query
    rst.MoveNext
    '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

        With olContact
            .CustomerID = Me.Name_ID
            .FirstName = Me.First_Name
            .MiddleName = Nz(Me.MI, "")
            .LastName = Me.Last_Name
            .FullName = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Me.Name_ID)
            .FileAs = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & Me.Name_ID)

            .Save
        End With
        'Move to the next record
        rst.MoveNext
        'Start over again with the next record in the table/query
    Loop
    MsgBox "Done"

End Sub
 

MickJav

It wasn't me
Local time
Today, 12:04
Joined
Nov 28, 2005
Messages
2,387
Have you created the field CustomerID in outlook I haven't worked with outlook in years but used to do that and had to create the field

keep safe mick
 

MickJav

It wasn't me
Local time
Today, 12:04
Joined
Nov 28, 2005
Messages
2,387
And why are you using a form and not the recordset:
Me.Name_ID
 

MickJav

It wasn't me
Local time
Today, 12:04
Joined
Nov 28, 2005
Messages
2,387
Lol No Worries I'llsee If I can edit your code give me ten
 

MickJav

It wasn't me
Local time
Today, 12:04
Joined
Nov 28, 2005
Messages
2,387
I've made a number of changes as listed
Added , dbOpenSnapshot to recordset
Altered the first move next to rst.MoveFirst this assumes there is at least one record
The me has been replaces with rst("Name_ID")
On delookup changed me for rst("Name_ID") but this assumes it is a long not string

As I said it's been years since I did anything with outlook so not sure what will happen if it finds a customerID already added hope it works let me know

keep safe mick

Private Sub ExportAccessContacts_Click()
On Error GoTo Error_Handler
Dim OlApp As Object
Dim olContact As Object
Const olContactItem = 2

Set OlApp = CreateObject("Outlook.Application")
Set olContact = OlApp.CreateItem(olContactItem)

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)

lngContactID = rst([Name_ID])
strFile = "C:\Users\" & fOSUserName() & "\Pictures\AVC_Backend\Contacts\" & Me.First_Name & " " & Me.Last_Name & ".png"

Set appOutlook = GetObject(, "Outlook.Application")
Set nms = appOutlook.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(olFolderContacts)
Set con = fld.Items.Find("[CustomerID] = " & lngContactID)

'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

With olContact
.CustomerID = rst("Name_ID")
.FirstName = rst("First_Name")
.MiddleName = Nz(rst("MI"), "")
.LastName = rst("Last_Name")
.FullName = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & rst("Name_ID"))
.FileAs = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & rst("Name_ID"))

.Save
End With
'Move to the next record
rst.MoveNext
'Start over again with the next record in the table/query
Loop
MsgBox "Done"

End Sub
 

MickJav

It wasn't me
Local time
Today, 12:04
Joined
Nov 28, 2005
Messages
2,387
If added error handling and removed the first error statment
On Error GoTo Error_Handler

Make sure you are useing Option Explicit On all your modules inc form modules

mick
Private Sub ExportAccessContacts_Click()
Dim OlApp As Object
Dim olContact As Object
On Error GoTo HandleErr

Const olContactItem = 2

Set OlApp = CreateObject("Outlook.Application")
Set olContact = OlApp.CreateItem(olContactItem)

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)

lngContactID = rst([Name_ID])
strFile = "C:\Users\" & fOSUserName() & "\Pictures\AVC_Backend\Contacts\" & Me.First_Name & " " & Me.Last_Name & ".png"

Set appOutlook = GetObject(, "Outlook.Application")
Set nms = appOutlook.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(olFolderContacts)
Set con = fld.Items.Find("[CustomerID] = " & lngContactID)

'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

With olContact
.CustomerID = rst("Name_ID")
.FirstName = rst("First_Name")
.MiddleName = Nz(rst("MI"), "")
.LastName = rst("Last_Name")
.FullName = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & rst("Name_ID"))
.FileAs = DLookup("[FullName]", "[q_Contacts_Search]", "[Name_ID]=" & rst("Name_ID"))

.Save
End With
'Move to the next record
rst.MoveNext
'Start over again with the next record in the table/query
Loop
MsgBox "Done"

HandleExit:
Exit Sub

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

dgreen

Member
Local time
Today, 06:04
Joined
Sep 30, 2018
Messages
396
Have Option Explicit on all modules.
I have an error handler at the bottom of the code.

Name _ID is a number value. For some reason, this code "lngContactID = rst([Name_ID])" is picking up the Last_Name field for the 1st record, leading to the error message.

If added error handling and removed the first error statment
On Error GoTo Error_Handler

Make sure you are useing Option Explicit On all your modules inc form modules
 

MickJav

It wasn't me
Local time
Today, 12:04
Joined
Nov 28, 2005
Messages
2,387
It should read rst("Name_ID")

But you need to move things around I'll see If I can find my old code
 

dgreen

Member
Local time
Today, 06:04
Joined
Sep 30, 2018
Messages
396
Made that change. Clicked the button and it started. We're much closer.

Looking at Outlook, it looked like a record was being created but wasn't being saved. I could see the names briefly before they were replaced with another. At the end though there was only 1 record saved in the Outlook Contacts.

It should read rst("Name_ID")
 

dgreen

Member
Local time
Today, 06:04
Joined
Sep 30, 2018
Messages
396
I need to break for a meeting. Will get back on this in a couple.

Made that change. Clicked the button and it started. We're much closer.

Looking at Outlook, it looked like a record was being created but wasn't being saved. I could see the names briefly before they were replaced with another. At the end though there was only 1 record saved in the Outlook Contacts.
 

Users who are viewing this thread

Top Bottom