VBA Outlook Contact Folders

Hello,

I'm using the code sample below to import contacts from Access into Outlook.
This works fine, except it always goes into the main Contacts folder.

I need to specify a different folder of contacts (NOT public folders).  I've created a sub-folder under Contacts called Publishers.  I've also created a folder called Publishers at the same level as the Contacts, Inbox, etc.

I've tried a variations on .folders.item  (array # references), as well as folder names, but can't get it to work.  I've tried things like:
Set cf = olns.GetDefaultFolder(olFolderContacts).Folders.Item(1)
Set cf = olns.GetDefaultFolder(olFolderContacts)
Folders.Item

Any tips would be very much appreciated.  Here's the code sample:

Sub ExportAccessContactsToOutlook()

   'Set up DAO Objects:
   Dim oDataBase As Object
   Dim rst As Object
   Set oDataBase = OpenDatabase _
     ("c:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb")
   Set rst = oDataBase.OpenRecordset("Customers")

   'Set up Outlook Objects:
   Dim olns As Object               ' Outlook Namespace
   Dim cf As Object                 ' Contact folder
   Dim c As Object                  ' Contact Item
   Dim Prop As Object               ' User property
   Dim ol As New Outlook.Application
   Set olns = ol.GetNamespace("MAPI")
   Set cf = olns.GetDefaultFolder(olFolderContacts)

   With rst
      .MoveFirst
      ' Loop through the Access records
      Do While Not .EOF
         ' Create a new Contact item
         Set c = ol.CreateItem(olContactItem)
         ' Specify which Outlook form to use:
         ' Change "IPM.Contact" to "IPM.Contact.<formname>" if you've
         ' created a custom Contact form in Outlook.
         c.MessageClass = "IPM.Contact"
         ' Create all built-in Outlook fields
         If ![CompanyName] <> "" Then c.CompanyName = ![CompanyName]
         If ![ContactName] <> "" Then c.FullName = ![ContactName]
         ' Create the first user property (UserField1)
         Set Prop = c.UserProperties.Add("UserField1", olText)
         ' Set its value
         If ![CustomerID] <> "" Then Prop = ![CustomerID]
         ' Create the second user property (UserField2)
         Set Prop = c.UserProperties.Add("UserField2", olText)
         ' Set it's value, and so on....
         If ![Region] <> "" Then Prop = ![Region]
         ' Save the contact
         c.Save
         .MoveNext
      Loop
   End With
   End Sub
Start Free Trial