Access Contacts to Outlook - Need Code for Public Folder

[abinboston]

I found this code for exporting Access data to Outlook
The example uses the default contacts folder
How can I use a Public Folder- named All Public Folders/CompanyContacts
Thanks - AB


'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