Solved Export All Access Contacts to Outlook

D

dgreen

Member
Local time
Today, 00:29
Joined
Sep 30, 2018
Messages
397
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
 
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.
 
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
 
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.
 
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.

vba_php said:
instead of writing all that code which would cause you to pull your hair out
Click to expand...
 
dgreen said:
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.
Click to expand...
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
 
bastanu said:
There are a few problems with your code.
Click to expand...

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:
 
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
 
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
 
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
Click to expand...
 
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
Click to expand...
 
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.

MickJav said:
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
Click to expand...
 
It should read rst("Name_ID")

But you need to move things around I'll see If I can find my old code
 
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.

MickJav said:
It should read rst("Name_ID")
Click to expand...
 
I need to break for a meeting. Will get back on this in a couple.

dgreen said:
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.
Click to expand...
 
You must log in or register to reply here.

Similar threads

K
'Next n' Looping rather than moving to the next record
Replies
16
Views
418
arnelgp
arnelgp
C
.MoveNext not working
2 3
Replies
44
Views
4,367
SHANEMAC51
SHANEMAC51
L
Export data from Access to Word with VBA
Replies
12
Views
1,216
arnelgp
arnelgp
S
Access to Outlook Contacts with ContID
2
Replies
24
Views
1,914
silentwolf
S
D
Selectively Control Updating Outlook Contact from Access
Replies
4
Views
1,199
Gasman
Gasman

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom