Solved Export All Access Contacts to Outlook

Hi guys,

No need for dLookups for full name and fileas as the recordset is based on that query, simply use .FullName=rst("FullName")

Cheers,
Vlad
 
Thanks didn't notice that lol
you have other problems in this line
strFile = "C:\Users\" & fOSUserName() & "\Pictures\AVC_Backend\Contacts\" & Me.First_Name & " " & Me.Last_Name & ".png"
need to replace the me. for rst

And move the code around to it's in the loop

I have to go hope you get it sorted night
 
Try this, you need to have the lngContactID inside the loop:
Code: 
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)


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\AVC_Backend\Contacts\" & rst("First_Name") & " " & rst("Last_Name") & ".png"
    Set con = fld.Items.Find("[CustomerID] = " & lngContactID)


    With olContact
        .CustomerID = rst("Name_ID")
        .FirstName = rst("First_Name")
        .MiddleName = Nz(rst("MI"), "")
        .LastName = rst("Last_Name")
        .FullName = rst("FullName")
        .FileAs = rst("FullName")
    .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

Cheers,
Vlad
 
Just found my old outlook module have uploading it hope it helps

Login

Login
databasedreams.createaforum.com databasedreams.createaforum.com

Hope it helps but it's very very old like me :ROFLMAO:
 
Made the changes you all have recommended.

The code runs but it's not saving a single record, until it reaches the last record. That is the only record saved.

Visually you can see the names showing up for a spilt second as the vba loops thru them but only one record is in Outlook at the end of this.

bastanu said:
Try this, you need to have the lngContactID inside the loop:
Click to expand...
 
Current code

Code: 
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)
      
    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\AVC_Backend\Contacts\" & rst("First_Name") & " " & rst("Last_Name") & ".png"
        Set con = fld.Items.Find("[CustomerID] = " & lngContactID)
        
        
        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(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(rst("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)
'            End If
            .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
End Sub
 
Thanks. That's the code that I started with and works for me clicking on one record at a time to populate Outlook.

This post is about making that code run through all records and populate Outlook's Contacts.

MickJav said:
Hope this help plus search the forum for outlook or look in similar threads
Click to expand...
 
Try this
Code: 
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\AVC_Backend\Contacts\" & rst("First_Name") & " " & rst("Last_Name") & ".png"

        Set con = fld.Items.Find("[CustomerID] = " & lngContactID)       

        Set olContact = OlApp.CreateItem(olContactItem)

        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(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(rst("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)

'            End If

            .Save

        End With

        'Move to the next record

        rst.MoveNext

        'Start over again with the next record in the table/query

    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

Cheers,
Vlad
:
 
Sorry, I should have explained what I did, in your code you were using the CreateItem method outside of the recordset loop (Set olContact = OlApp.CreateItem(olContactItem)) so you were overwriting the same object until the very last record.

Cheers,
Vlad
 
It fails to compile at this point.

bastanu said:
Set olContact = OlApp.CreateItem(olContactItem)
Click to expand...

Thanks for the information and support to get me to this point.

bastanu said:
Sorry, I should have explained what I did, in your code you were using the CreateItem method outside of the recordset loop (Set olContact = OlApp.CreateItem(olContactItem)) so you were overwriting the same object until the very last record.
Click to expand...
 
Sorry about that, it looked like you were not using that instance so I commented it out.

Cheers,
Vlad
 
The code uploaded 697 of the 750+ contact and then stopped at a record that apparently it didn't like. I'm troubleshooting it. Issue 1 was a malformed email address (I have code that should have caught it).

Question based on how we've coded this, if I run the button again, it shouldn't duplicate the contact right? It should see the CustomerID and move to the next contact.
 
You need to find out what is wrong with those that didn't get uploaded, if I remember correctly I used to synce the contacts its been 20 years from the date on my code so can't really help beyond this point

Good luck with your project mick
 
You need to pay attention and streamline the Outlook side of code a bit. You are declaring and using a couple ofOutlok.Application variables and you set the con variable ( Set con = fld.Items.Find("[CustomerID] = " & lngContactID) ) but you do not do anything with it. I would expect that line or the next to check if con=Nothing (meaning the contactid was not found) then continue to add else GoTo a label ExistingContact: just above the rst.movenext in the loop.

I will be offline for a while (wedding anniversary today :)), but see what you can get going and I'll follow up tomorrow if still needed.

Cheers,
Vlad
 
Been Checking the code and the way I used to do it 20 years ago was I had a field in my customers table that I used to filter when uploading new customers so only ones not alrady in outlook were uploaded

This is what I called it InOutlook

when the upload of all customers was compleate I ran an update query as below
StrSQLUpDate = "UPDATE PtblCustomers SET PtblCustomers.InOutlook = True WHERE (((PtblCustomers.InOutlook)=False));"
dbs.Execute (StrSQLUpDate)
Click to expand...

This was placed after the loop but before any error code

then the query you are using you should limit the results by InOutlook =false that way you only upload new csomtomers and don't have to worry about duplicates

But should you want to use it you can check the results of this line

Set con = fld.Items.Find("[CustomerID] = " & lngContactID)

Not 100% sure on this but you could check con =nothing I.E. If Not Len(Con.CustomerID & "") > 0 Then

hope it helps

keep safe mick
 
Last edited:
bastanu said:
You need to pay attention and streamline the Outlook side of code a bit. You are declaring and using a couple ofOutlok.Application variables and you set the con variable ( Set con = fld.Items.Find("[CustomerID] = " & lngContactID) ) but you do not do anything with it. I would expect that line or the next to check if con=Nothing (meaning the contactid was not found) then continue to add else GoTo a label ExistingContact: just above the rst.movenext in the loop.

I will be offline for a while (wedding anniversary today :)), but see what you can get going and I'll follow up tomorrow if still needed.

Cheers,
Vlad
Click to expand...
I was just going to ask what the con= was for :D
 
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