D
Dale Fye
After several searches of the newsgroups, and with some cobbling together, I
now have a subroutine that will read the pertinent fields from my Outlook
contacts list, and populate a table in my database. However, I would like
to use late binding as I have users running both Office 2003 and 2007 and
want to avoid any reference problems.
I've played around with this code until I am blue in the face, but am still
unable to get it to run properly without the reference to the Outlook object
library. The line where it generally gives me an error the one that reads:
If TypeOf Contact Is Outlook.ContactItem Then
Also, if Outlook was not open when this code runs, I set set a flag (bOpen)
to False, and would like to close the instance of Outlook just before I go
into the Exit portion of the subroutine. However, the myOLApp object does
not appear to have a close or quit method. What method should I use to
close Outlook.
Dale
Public Sub OutlookContacts(Optional Reset As Boolean = False)
Dim myOlApp As Object 'Outlook.Application
Dim olns As Object
Dim objFolder As Object
Dim objAllContacts As Object
Dim Contact As Object
Dim myItem As Object 'Outlook.ContactItem
Dim bOpen As Boolean
Dim strSQL As String
Dim rs As DAO.Recordset
DoCmd.Hourglass True
Static ContactsAreLoaded As Boolean
'If the contact list has already been loaded, then skip this step
If ContactsAreLoaded And Not Reset Then GoTo ContactsExit
On Error Resume Next
Set myOlApp = GetObject(, "Outlook.Application")
If Err.Number = 0 Then
bOpen = True
Else
Debug.Print Err.Number, Err.Description
bOpen = False
Set myOlApp = CreateObject("Outlook.Application")
End If
On Error GoTo ContactsError
'Empty tbl_OutlookContacts if necessary
strSQL = "DELETE * FROM tbl_OutlookContacts"
CurrentDb.Execute strSQL, dbFailOnError
'Open the local contacts table
strSQL = "SELECT * FROM tbl_OutlookContacts"
Set rs = CurrentDb.OpenRecordset(strSQL, , dbFailOnError)
Set myItem = myOlApp.CreateItem(2) 'olContactItem
' Set the Namespace object.
Set olns = myOlApp.GetNamespace("MAPI")
' Set the default Contacts folder.
Set objFolder = olns.GetDefaultFolder(10) 'olFolderContacts
' Set objAllContacts equal to the collection of all contacts.
Set objAllContacts = objFolder.Items
' Loop through each contact.
For Each Contact In objAllContacts
DoEvents
If TypeOf Contact Is Outlook.ContactItem Then
Set myItem = Contact
rs.AddNew
rs("lastname") = myItem.lastname
rs("firstname") = myItem.firstname
rs("phone_Business") = myItem.BusinessTelephoneNumber
rs("phone_Home") = myItem.HomeTelephoneNumber
rs("phone_Mobile") = myItem.MobileTelephoneNumber
rs("email_1") = myItem.email1address
rs("email_2") = myItem.Email2Address
rs("email_3") = myItem.Email3Address
rs("Company_Name") = myItem.CompanyName
rs("Department") = myItem.Department
rs("Job_Title") = myItem.JobTitle
rs.Update
End If
Next
ContactsAreLoaded = True
If bOpen = False And Not myOlApp Is Nothing Then
myOlApp.Close
End If
ContactsExit:
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
DoCmd.Hourglass False
Exit Sub
ContactsError:
MsgBox Err.Number & vbCrLf & Err.Description
Debug.Print Err.Number & vbCrLf & Err.Description
Resume ContactsExit
End Sub
now have a subroutine that will read the pertinent fields from my Outlook
contacts list, and populate a table in my database. However, I would like
to use late binding as I have users running both Office 2003 and 2007 and
want to avoid any reference problems.
I've played around with this code until I am blue in the face, but am still
unable to get it to run properly without the reference to the Outlook object
library. The line where it generally gives me an error the one that reads:
If TypeOf Contact Is Outlook.ContactItem Then
Also, if Outlook was not open when this code runs, I set set a flag (bOpen)
to False, and would like to close the instance of Outlook just before I go
into the Exit portion of the subroutine. However, the myOLApp object does
not appear to have a close or quit method. What method should I use to
close Outlook.
Dale
Public Sub OutlookContacts(Optional Reset As Boolean = False)
Dim myOlApp As Object 'Outlook.Application
Dim olns As Object
Dim objFolder As Object
Dim objAllContacts As Object
Dim Contact As Object
Dim myItem As Object 'Outlook.ContactItem
Dim bOpen As Boolean
Dim strSQL As String
Dim rs As DAO.Recordset
DoCmd.Hourglass True
Static ContactsAreLoaded As Boolean
'If the contact list has already been loaded, then skip this step
If ContactsAreLoaded And Not Reset Then GoTo ContactsExit
On Error Resume Next
Set myOlApp = GetObject(, "Outlook.Application")
If Err.Number = 0 Then
bOpen = True
Else
Debug.Print Err.Number, Err.Description
bOpen = False
Set myOlApp = CreateObject("Outlook.Application")
End If
On Error GoTo ContactsError
'Empty tbl_OutlookContacts if necessary
strSQL = "DELETE * FROM tbl_OutlookContacts"
CurrentDb.Execute strSQL, dbFailOnError
'Open the local contacts table
strSQL = "SELECT * FROM tbl_OutlookContacts"
Set rs = CurrentDb.OpenRecordset(strSQL, , dbFailOnError)
Set myItem = myOlApp.CreateItem(2) 'olContactItem
' Set the Namespace object.
Set olns = myOlApp.GetNamespace("MAPI")
' Set the default Contacts folder.
Set objFolder = olns.GetDefaultFolder(10) 'olFolderContacts
' Set objAllContacts equal to the collection of all contacts.
Set objAllContacts = objFolder.Items
' Loop through each contact.
For Each Contact In objAllContacts
DoEvents
If TypeOf Contact Is Outlook.ContactItem Then
Set myItem = Contact
rs.AddNew
rs("lastname") = myItem.lastname
rs("firstname") = myItem.firstname
rs("phone_Business") = myItem.BusinessTelephoneNumber
rs("phone_Home") = myItem.HomeTelephoneNumber
rs("phone_Mobile") = myItem.MobileTelephoneNumber
rs("email_1") = myItem.email1address
rs("email_2") = myItem.Email2Address
rs("email_3") = myItem.Email3Address
rs("Company_Name") = myItem.CompanyName
rs("Department") = myItem.Department
rs("Job_Title") = myItem.JobTitle
rs.Update
End If
Next
ContactsAreLoaded = True
If bOpen = False And Not myOlApp Is Nothing Then
myOlApp.Close
End If
ContactsExit:
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
DoCmd.Hourglass False
Exit Sub
ContactsError:
MsgBox Err.Number & vbCrLf & Err.Description
Debug.Print Err.Number & vbCrLf & Err.Description
Resume ContactsExit
End Sub