K
kenista
I am using Access 2007 and Outlook 2007. I am trying to import selected
contacts from my address book into a table in my database called
ContactPeople.
The table has the following fields:
ID - primary key & autonumbered
FirstName
LastName
CompanyName
TelephoneNumber
FaxNumber
MobileNumber
EmailAddress
I have tried a few things, including creating the module below, but am
unable to get any fields to populate.
Sub ImportContactsFromOutlook()
' This code is based in Microsoft Access.
' Set up DAO objects (uses existing "ContactPeople" table)
Dim rst As DAO.Recordset
Dim iNumContacts As Long
Dim i As Long
Set rst = CurrentDb.OpenRecordset("OLContacts")
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.GetDefaultFolder(olFolderContacts)
Set objItems = cf.Items
iNumContacts = objItems.Count
If iNumContacts <> 0 Then
For i = 1 To iNumContacts
If TypeName(objItems(i)) = "ContactItem" Then
Set c = objItems(i)
' If c.Categories = "Importthisone" Then 'I only need certain
categories
rst.AddNew
' Pick up all the fields you want here
rst!FirstName = c.FirstName
rst!LastName = c.LastName
rst!CompanyName = c.CompanyName
rst!EmailAddress = c.EmailAddress
rst.Update
End If
' End If
Next i
rst.Close
Else
MsgBox "No contacts to import"
End If
End Sub
Please help
contacts from my address book into a table in my database called
ContactPeople.
The table has the following fields:
ID - primary key & autonumbered
FirstName
LastName
CompanyName
TelephoneNumber
FaxNumber
MobileNumber
EmailAddress
I have tried a few things, including creating the module below, but am
unable to get any fields to populate.
Sub ImportContactsFromOutlook()
' This code is based in Microsoft Access.
' Set up DAO objects (uses existing "ContactPeople" table)
Dim rst As DAO.Recordset
Dim iNumContacts As Long
Dim i As Long
Set rst = CurrentDb.OpenRecordset("OLContacts")
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.GetDefaultFolder(olFolderContacts)
Set objItems = cf.Items
iNumContacts = objItems.Count
If iNumContacts <> 0 Then
For i = 1 To iNumContacts
If TypeName(objItems(i)) = "ContactItem" Then
Set c = objItems(i)
' If c.Categories = "Importthisone" Then 'I only need certain
categories
rst.AddNew
' Pick up all the fields you want here
rst!FirstName = c.FirstName
rst!LastName = c.LastName
rst!CompanyName = c.CompanyName
rst!EmailAddress = c.EmailAddress
rst.Update
End If
' End If
Next i
rst.Close
Else
MsgBox "No contacts to import"
End If
End Sub
Please help