Error Downloading Outlookfields using VBA

[Dave F]

I am trying to download the standard Outlook fields into Access 2003 using
the Outlook object model and VBA.

The process works but I am getting one intermittent error. When I try to
set an Outlook.ContactItem I get a runtime error 13, TypeMismatch on the
second line below:

If TypeName(objItems(i)) = "ContactItem" Then
Set c = objItems(i)

I have tried deleting ths particular contact item from Outlook but the error
persists at the same point in the loop.

Does anyone have any idea why I might get a type mismatch?

Below is my complete code.

Thanks for any ideas.
Dave


----------------------------------------
Code from Access 2003 Form Module


Option Compare Database

'Set reference to Microsoft DAO 3.6 Object Library
'Set reference to Microsoft Outlook 11. Object Library


Private Sub Command0_Click()

'On Error GoTo Err_Handler

'reset progress bar
If Me.pbIn.Visible = True Then
Me.pbIn.Visible = False
Me.lblProgress.Visible = False
End If

'Call sub to import both standard fields
Call ImportContactsFromOutlook

Exit_sub:
Exit Sub

Err_Handler:
MsgBox ("error number: " & Err.Number _
& " Description: " & Err.Description)
Resume Exit_sub

End Sub


Sub ImportContactsFromOutlook()

Dim i As Integer 'counter
Dim strFolderName As String 'Outlook folder
Dim strFolderPath As String 'Outlook folder path


'get folder name from drop down box selection
strFolderName = cboFolder.Value
strFolderPath = "Public Folders\All Public Folders\" & strFolderName


'DAO Objects
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Import_OL_STD")

'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
Dim Prop As Outlook.UserProperty


Set olns = ol.GetNamespace("MAPI")

'Reference to local folder
' Set cf = olns.GetDefaultFolder(olFolderContacts)
' Set cf = olns.GetDefaultFolder(olPublicFoldersAllPublicFolders)


'Call function to return proper folder object
Set cf = GetFolder(strFolderPath)
Set objItems = cf.Items
iNumContacts = objItems.Count

If iNumContacts <> 0 Then

'turn label and progress bar on
Me.lblProgress.Caption = iNumContacts & " potential records to
import."
Me.lblProgress.Visible = True

Me.pbIn.Visible = True
iPBOutWidth = Me.pbOut.Width

For i = 1 To iNumContacts

'set progress bar
'size of inner box= (size of outer box/# records) * current
record
Me.pbIn.Width = (iPBOutWidth / iNumContacts) * i
Me.Repaint

If TypeName(objItems(i)) = "ContactItem" Then

'*********** RUNTIME ERROR 13 TYPE MISMATCH occurs here on the 143 record
Set c = objItems(i)
rst.AddNew

'Grab Outlook standard properties
rst![CompanyName] = c.CompanyName
rst![PublicFolder] = strFolderName
' rst![Actions] = c.Actions
rst![Application] = c.Application
rst![Companies] = c.Companies
rst![CompanyAndFullName] = c.CompanyAndFullName
rst![Email1AddressType] = c.Email1AddressType
rst![Email1DisplayName] = c.Email1DisplayName
rst![Email1EntryID] = c.Email1EntryID
rst![Email2AddressType] = c.Email2AddressType
rst![Email2DisplayName] = c.Email2DisplayName
' too small rst![Email2EntryID] = c.Email2EntryID
rst![Email3AddressType] = c.Email3AddressType
rst![Email3DisplayName] = c.Email3DisplayName
'not found rst![Email3EntryID] = c.Email3EntryID
rst![EntryID] = c.EntryID
rst![FormDescription] = c.FormDescription
rst![FullNameAndCompany] = c.FullNameAndCompany
rst![GetInspector] = c.GetInspector
rst![Importance] = c.Importance
rst![LastNameAndFirstName] = c.LastNameAndFirstName
rst![MailingAddressCity] = c.MailingAddressCity
rst![MailingAddressCountry] = c.MailingAddressCountry
rst![MailingAddressPostalCode] = c.MailingAddressPostalCode
rst![MailingAddressPostOfficeBox] =
c.MailingAddressPostOfficeBox
rst![MailingAddressState] = c.MailingAddressState
rst![MailingAddressStreet] = c.MailingAddressStreet
rst![NoAging] = c.NoAging
rst![Parent] = c.Parent
rst![Saved] = c.Saved
rst![SelectedMailingAddress] = c.SelectedMailingAddress
rst![UnRead] = c.UnRead
rst![UserCertificate] = c.UserCertificate
' rst![UserProperties] = c.UserProperties
rst![YomiCompanyName] = c.YomiCompanyName
rst![YomiFirstName] = c.YomiFirstName
rst![YomiLastName] = c.YomiLastName
rst![Account] = c.Account
rst![Anniversary] = c.Anniversary
rst![AssistantName] = c.AssistantName
rst![AssistantTelephoneNumber] = c.AssistantTelephoneNumber
' rst![Attachments] = c.Attachments
rst![BillingInformation] = c.BillingInformation
rst![Birthday] = c.Birthday
rst![BusinessAddress] = c.BusinessAddress
rst![BusinessAddressCity] = c.BusinessAddressCity
rst![BusinessAddressCountry] = c.BusinessAddressCountry
rst![BusinessAddressPostOfficeBox] =
c.BusinessAddressPostOfficeBox
rst![BusinessAddressPostalCode] =
c.BusinessAddressPostalCode
rst![BusinessAddressState] = c.BusinessAddressState
rst![BusinessAddressStreet] = c.BusinessAddressStreet
rst![BusinessFaxNumber] = c.BusinessFaxNumber
rst![BusinessHomePage] = c.BusinessHomePage
rst![BusinessTelephoneNumber] = c.BusinessTelephoneNumber
rst![Business2TelephoneNumber] = c.Business2TelephoneNumber
rst![CallbackTelephoneNumber] = c.CallbackTelephoneNumber
rst![CarTelephoneNumber] = c.CarTelephoneNumber
rst![Categories] = c.Categories
rst![Children] = c.Children
rst![CompanyMainTelephoneNumber] =
c.CompanyMainTelephoneNumber
rst![ComputerNetworkName] = c.ComputerNetworkName
rst![CreationTime] = c.CreationTime
rst![CustomerID] = c.CustomerID
rst![Department] = c.Department
rst![Email1Address] = c.Email1Address
rst![Email2Address] = c.Email2Address
rst![Email3Address] = c.Email3Address
rst![FileAs] = c.FileAs
rst![FirstName] = c.FirstName
rst![FTPSite] = c.FTPSite
rst![FullName] = c.FullName
rst![Gender] = c.Gender
rst![GovernmentIDNumber] = c.GovernmentIDNumber
rst![Hobby] = c.Hobby
rst![HomeAddress] = c.HomeAddress
rst![HomeAddressCity] = c.HomeAddressCity
rst![HomeAddressCountry] = c.HomeAddressCountry
rst![HomeAddressPostOfficeBox] = c.HomeAddressPostOfficeBox
rst![HomeAddressPostalCode] = c.HomeAddressPostalCode
rst![HomeAddressState] = c.HomeAddressState
rst![HomeAddressStreet] = c.HomeAddressStreet
rst![HomeFaxNumber] = c.HomeFaxNumber
rst![HomeTelephoneNumber] = c.HomeTelephoneNumber
rst![Home2TelephoneNumber] = c.Home2TelephoneNumber
' rst![Icon] = c.Icon ' doesn't support method or property
rst![Initials] = c.Initials
rst![ISDNNumber] = c.ISDNNumber
rst![JobTitle] = c.JobTitle
rst![Journal] = c.Journal
rst![Language] = c.Language
rst![LastName] = c.LastName
rst![MailingAddress] = c.MailingAddress
rst![ManagerName] = c.ManagerName
rst![MessageClass] = c.MessageClass
rst![MiddleName] = c.MiddleName
rst![Mileage] = c.Mileage
rst![MobileTelephoneNumber] = c.MobileTelephoneNumber
rst![LastModificationTime] = c.LastModificationTime
rst![NickName] = c.NickName
rst![Body] = c.Body
rst![OfficeLocation] = c.OfficeLocation
rst![OrganizationalIDNumber] = c.OrganizationalIDNumber
rst![OtherAddress] = c.OtherAddress
rst![OtherAddressCity] = c.OtherAddressCity
rst![OtherAddressCountry] = c.OtherAddressCountry
rst![OtherAddressPostOfficeBox] =
c.OtherAddressPostOfficeBox
rst![OtherAddressPostalCode] = c.OtherAddressPostalCode
rst![OtherAddressState] = c.OtherAddressState
rst![OtherAddressStreet] = c.OtherAddressStreet
rst![OtherFaxNumber] = c.OtherFaxNumber
rst![OtherTelephoneNumber] = c.OtherTelephoneNumber
rst![OutlookInternalVersion] = c.OutlookInternalVersion
rst![OutlookVersion] = c.OutlookVersion
rst![PagerNumber] = c.PagerNumber
rst![PersonalHomePage] = c.PersonalHomePage
rst![PrimaryTelephoneNumber] = c.PrimaryTelephoneNumber
rst![Profession] = c.Profession
rst![RadioTelephoneNumber] = c.RadioTelephoneNumber
rst![ReferredBy] = c.ReferredBy
rst![Sensitivity] = c.Sensitivity
rst![Size] = c.Size
rst![Spouse] = c.Spouse
rst![Subject] = c.Subject
rst![Suffix] = c.Suffix
rst![TelexNumber] = c.TelexNumber
rst![Title] = c.Title
rst![TTYTDDTelephoneNumber] = c.TTYTDDTelephoneNumber
rst![User1] = c.User1
rst![User2] = c.User2
rst![User3] = c.User3
rst![User4] = c.User4
rst![WebPage] = c.WebPage

rst.Update
End If

Set c = Nothing

Next i

rst.Close

MsgBox "Finished."

Else
MsgBox "No contacts to export."
End If

Set rst = Nothing
Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing




End Sub


Public Function GetFolder(strFolderPath As String) As MAPIFolder

' Folder path passed s/b in form
' "Public Folders\All Public Folders\Cal Net Clients"

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long

On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing


End Function