Function fnCreateOutlookContact()
' Declare all required object for this function.
Dim objContactItem As ContactItem
Dim snpContacts As DAO.Recordset
Dim intCurrRec As Integer, intRecCount As Integer
' Set application echo to true.
Application.Echo , True, _
"Initializing to Create Outlook Contacts. One moment please."
Set snpContacts = CurrentDb.OpenRecordset("Enter the table
Name", dbOpenSnapshot)
' Obtain the recordcount for the progress meter.
snpContacts.MoveLast
intRecCount = snpContact.RecordCount
snpContacts.MoveFirst
SysCmd acSysCmdInitMeter, "Creating Outlook Contacts...",
intRecCount, intCurrRec = 1
Set olkapp = CreateObject("Outlook.Application")
Set olkNamesSpcase = olkapp.GetNameSpace("MAPI")
' Create the Outlook contact entry for each contact
record.
Do Until snpContacts.EOF
' Make the meter update.
SysCmd acSysCmdUpdateMeter, intCurrRec
Set objContactItem = olk.App.CreateItem
(olContactItem)
' Declare all objects within the with statement.
With objContactItem
.FirstName = snpContacts!FirstName
.LastName = snpContacts!LastName
.BusinessAddress = snpContacts!Address
.BusinessAddressCity = snpContacts!City
.BusinessAddressState = snpContacts!State
.BusinessAddressPostalCode = snpContacts!
ZipCode
.BusinessTelephoneNumber = snpContacts!
PhoneNo
.Categories = "Access Contacts"
.Save
End With
' Move to the next record in the recordset.
snpContact.MoveNext
intCurrRec = intCurrRec + 1
Loop
' Time to close out the function.
Set objContactItem = Null
Set olknamespace = Null
Set olkapp = Null
SysCmd acSysCmdClearStatus
End Function
