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