Here is some code you might find useful. As I recall I found it on this website, and I was able to make it work.
Code:
Option Compare Database
Option Explicit
Sub AddToList(ListName As String, ContactName As String, Optional AList As Boolean = True)
On Error Resume Next
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myDistList As Outlook.DistListItem
Dim myTempItem As Outlook.MailItem
Dim myRecipients As Outlook.Recipients
Dim objcontacts As Outlook.MAPIFolder
Dim objcontact As Outlook.ContactItem
Dim myid, myname As String
If AList = True Then 'if true add, if not remove
'check to see if list already exists
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myDistList = objcontacts.Items("" & ListName)
If Err.Number = -2147221233 Then
GoTo Createmylist
Err.Clear
Else
GoTo AddToList
End If
Exit Sub
Createmylist:
' myid = frm.IDContact
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myTempItem = myOlApp.CreateItem(olMailItem)
Set myRecipients = myTempItem.Recipients
Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
Set myDistList = myOlApp.CreateItem(olDistributionListItem)
myname = objcontact.FullName
myDistList.DLName = "" & ListName
myRecipients.Add "" & myname
myRecipients.ResolveAll
myDistList.AddMembers myRecipients
myDistList.Close olSave
GoTo mycleanup
AddToList:
' myid = frm.IDContact
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myTempItem = myOlApp.CreateItem(olMailItem)
Set myRecipients = myTempItem.Recipients
Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
Set myDistList = objcontacts.Items("" & ListName)
myname = objcontact.FullName
myRecipients.Add "" & myname
myRecipients.ResolveAll
myDistList.AddMembers myRecipients
myDistList.Close olSave
GoTo mycleanup
Else ' remove in unchecked
'check to see if list already exists
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myDistList = objcontacts.Items("" & ListName)
If Err.Number = -2147221233 Then
Err.Clear
Exit Sub
Else
' myid = frm.IDContact
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myTempItem = myOlApp.CreateItem(olMailItem)
Set myRecipients = myTempItem.Recipients
Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
Set myDistList = objcontacts.Items("" & ListName)
End If
myname = objcontact.FullName
myRecipients.Add "" & myname
myRecipients.ResolveAll
myDistList.RemoveMembers myRecipients
myDistList.Close olSave
'check to see if list is populated, delete if empty
If myDistList.MemberCount = 0 Then
myDistList.Delete
End If
End If
mycleanup:
Set myOlApp = Nothing
Set myNameSpace = Nothing
Set myDistList = Nothing
Set myTempItem = Nothing
Set myRecipients = Nothing
Set objcontacts = Nothing
Set objcontact = Nothing
End Sub
Sub CreateList(ListName As String)
On Error GoTo ProcErr
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myDistList As Outlook.DistListItem
Dim myTempItem As Outlook.MailItem
Dim myRecipients As Outlook.Recipients
Dim objcontacts As Outlook.MAPIFolder
Dim objcontact As Outlook.ContactItem
Dim myid, myname As String
' myid = frm.IDContact
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myTempItem = myOlApp.CreateItem(olMailItem)
Set myRecipients = myTempItem.Recipients
Set objcontacts = myNameSpace.GetDefaultFolder(olFolderContacts)
Set objcontact = objcontacts.Items.Find("[user1] =" & myid)
Set myDistList = myOlApp.CreateItem(olDistributionListItem)
myname = objcontact.FullName
myDistList.DLName = "" & ListName
myRecipients.Add "" & myname
myRecipients.ResolveAll
myDistList.AddMembers myRecipients
myDistList.Close olSave
GoTo mycleanup
mycleanup:
Set myOlApp = Nothing
Set myNameSpace = Nothing
Set myDistList = Nothing
Set myTempItem = Nothing
Set myRecipients = Nothing
Set objcontacts = Nothing
Set objcontact = Nothing
Exit Sub
ProcErr:
MsgBox Err.Description
Err.Clear
GoTo mycleanup
End Sub
Function AddOlContact()
On Error GoTo Error_Handler
Const olContactItem = 2
Dim olApp As Object
Dim Ctct As Object
Dim olcontact
Set olApp = CreateObject("Outlook.Application")
Set olcontact = olApp.CreateItem(olContactItem)
With olcontact
.FirstName = "Daniel"
.LastName = "Alba"
.JobTitle = ""
.CompanyName = "MINI CARDA"
.BusinessAddressStreet = "22 ClearPoint"
.BusinessAddressCity = "Pointe-Claire"
.BusinessAddressState = "Quebec"
.BusinessAddressCountry = "Canada"
.BusinessAddressPostalCode = "H9X 3A6"
.BusinessTelephoneNumber = "(514) 488-0956"
.BusinessFaxNumber = ""
.Email1Address = "mini@mini.com"
.MobileTelephoneNumber = ""
.Save 'use .Display if you wish the user to see the contact pop-up
End With
Error_Handler_Exit:
On Error Resume Next
Set olcontact = Nothing
Set olApp = Nothing
Exit Function
Error_Handler:
MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: AddOlContact" & vbCrLf & "Error Description: " & _
Err.Description, vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
Sub ExportAccessContactsToOutlook()
' Set up DAO Objects.
Dim oDataBase As Database
Dim rst As Recordset
Dim SQL As String
' Set up Outlook Objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim QRS_Folder As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim Prop As Outlook.UserProperty
On Error GoTo ProcErr
' Set olns = ol.GetNamespace("MAPI")
Set olns = ol.GetNamespace("MAPI")
' Set cf = olns.GetDefaultFolder(olFolderContacts)
Set cf = olns.GetDefaultFolder(olFolderContacts)
Set QRS_Folder = cf.Folders("QRS_Search")
SQL = "Select * from [Global address list] where last = 'Goddard'"
Set oDataBase = CurrentDb
Set rst = oDataBase.OpenRecordset(SQL)
' QRS_Folder.Items.Add
' Set myOtherItem = myFolder.Items("Dan Wilson")
' Set c = myFolder.Items.Add
' c.CompanyName = myOtherItem.CompanyName
' c.BusinessAddress = myOtherItem.BusinessAddress
' c.BusinessTelephoneNumber = myOtherItem.BusinessTelephoneNumber
' myItem.Display
With rst
.MoveFirst
' Loop through the Microsoft Access records.
Do While Not .EOF
' Create a new Contact item.
' Set c = ol.CreateItem(olContactItem)
Set c = QRS_Folder.Items.Add
' Specify which Outlook form to use.
' Change "IPM.Contact" to "IPM.Contact.<formname>" if you've
' created a custom Contact form in Outlook.
c.MessageClass = "IPM.Contact"
' Create all built-in Outlook fields.
If ![Company] <> "" Then c.CompanyName = ![Company]
c.FirstName = ![first]
c.LastName = ![last]
c.Email1DisplayName = ![Display Name]
c.Account = ![Account]
c.Email1Address = ![Display Name]
c.User1 = ![Display Name]
' Save and close the contact.
c.Save
Debug.Print c.FirstName, c.LastName, c.EntryID
c.Close olSave
.MoveNext
Loop
End With
Exit Sub
ProcErr:
MsgBox Err.Description
End Sub