'Use a global constant for the message box caption.
Const MESSAGE_CAPTION = "Exporting Contacts to Microsoft Access"
 
Public Sub ExportContactsTable(strTableName As String)
 
	Dim oOutlook As New Outlook.Application
	Dim colItems As Items
	Dim tblContacts As Recordset
	Dim upContactId As UserProperty
	Dim strMessage as String
	
	Const ERR_TABLE_NOT_FOUND = 3078
	Const ERR_FIELD_NOT_FOUND = 3265
	Const ERR_ATTACHED_TABLE_NOT_FOUND = 3024
	Const ERR_INVALID_ATTACHED_TABLE_PATH = 3044

	On Error GoTo ERR_ExportContactsTable

	'Open the table.
	Set tblContacts = CurrentDb.OpenRecordset(strTableName)

	'Get a reference to the Items collection of the contacts folder.
	Set colItems = oOutlook.GetNamespace("MAPI"). _
						GetDefaultFolder(olFolderContacts).Items

		Do Until tblContacts.EOF
			If boolCheckName(Nz(tblContacts!ContactName), colItems) Then
				'Use the Add method of Items collection to fill in the 
				'fields with the data from the table and then save the new 
				'item.
				With colItems.Add
					.FullName = Nz(tblContacts!ContactName)
					.BusinessAddressStreet = Nz(tblContacts!Address)
					.BusinessAddressCity = Nz(tblContacts!City)
					.BusinessAddressState = Nz(tblContacts!Region)
					.BusinessAddressPostalCode = Nz(tblContacts!PostalCode)
					.BusinessAddressCountry = Nz(tblContacts!Country)
					.BusinessTelephoneNumber = Nz(tblContacts!Phone)
					.BusinessFaxNumber = Nz(tblContacts!Fax)
					.CompanyName = Nz(tblContacts!CompanyName)
					.JobTitle = Nz(tblContacts!ContactTitle)

					'Create a custom field.
					Set upContactId = .UserProperties. _ 
							Add("ContactID", olText)

					upContactId = Nz(tblContacts![CustomerID])

					.Save
				End With
			End If
			tblContacts.MoveNext
		Loop
		tblContacts.Close
		
		strMessage = "Your contacts have been successfully exported."
		MsgBox strMessage, vbOKOnly, MESSAGE_CAPTION
Exit_ExportContactsTable:
	On Error Resume Next

	Set tblContacts = Nothing
	Set oOutlook = Nothing

	Exit Sub 
ERR_ExportContactsTable:

	Select Case Err
		Case ERR_TABLE_NOT_FOUND
			strMessage = "Cannot find table!"
			MsgBox strMessage, vbCritical, MESSAGE_CAPTION
			Resume Exit_ExportContactsTable

			'These errors occur if an attached table is moved or deleted
			'or if the path to the table file is no longer valid.
			Case ERR_ATTACHED_TABLE_NOT_FOUND, ERR_INVALID_ATTACHED_TABLE_PATH
				strMessage = "Cannot find attached table!"
				MsgBox strMessage, vbCritical, MESSAGE_CAPTION
				Resume Exit_ExportContactsTable

			'If a field in the code does not match a field in the table
			'then move on to the next field.
			Case ERR_FIELD_NOT_FOUND
				Resume Next
			Case Else
				strMessage = "An unexpected error has occured. Error#" _
							& Err & ": " & Error
				MsgBox strMessage, vbCritical, MESSAGE_CAPTION
				Resume Exit_ExportContactsTable
		End Select

End Sub

Function boolCheckName(strName As String, colItems As Items) _
					As Boolean

	Dim varSearchItem As Variant
	Dim strMessage As String

	If Len(strName) = 0 Then
		strMessage = "This record is missing a full name. "
		strMessage = strMessage & "Do you want to add it anyway?"
		If MsgBox(strMessage, vbYesNo, MESSAGE_CAPTION) = vbYes Then
			boolCheckName = True
		Else
			boolCheckName = False
		End If
	Else
		'Find the first item that has a FullName equal to strName. If no
		'item is found, varSearchItem wil be equal to Nothing.
		Set varSearchItem = colItems.Find("[FullName] = """ & strName & """")
		If varSearchItem Is Nothing Then
			boolCheckName = True
		Else
			strMessage = "A contact named " & strName & " already exists. "
			strMessage = strMessage & _
						"Do you want to add this contact anyway?"

			If MsgBox(strMessage, vbYesNo, MESSAGE_CAPTION) = vbYes Then
			boolCheckName = True
			Else
				boolCheckName = False
			End If
		End If
	End If
End Function