Need VBA script to export and import public folder contact list

Hello all,

I currently work in an organization that has contact list in a public folder. The biggest problem with this is that synchronization cannot be done on public folders to replicate newly entered contacts. The only way that contacts can be viewed is by going through OWA. I have a couple of users that have PDAs - so being able to sync with a contact list would be a better solution.

I am wondering if anyone has a snippet of vb code that could be used to export the contacts from the public folder then import this data to a private contacts folder.


Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

David LeeCommented:
Hi, Shawna.

I believe I can provide what you're looking for.  I'll post it within the next 24 hours.

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
David LeeCommented:
Here's the code for what you want to do.  I tested it in my Exchange/Outlook environment and it works fine.  Right now it just copies all the contacts from the source folder to the destination folder.  If the destination folder already contains any of the contacts being copied, then this process will create a second copy of those contacts.  That's probably not what you want to happen.  There are two ways around this.  One, delete all the contact from the destination folder each time before running this code.  You can do that manually or the code could be modified to do it for you.  Two, modify the code to perform a true synchronization.  That's more complicated than the former solution, but certainly doable.  The code here is straight VB and is intended to be run from outside Outlook.

Hope this helps.

-- BDF

Private Sub Command1_Click()
    Dim olApp As New Outlook.Application, _
        olNS As Outlook.NameSpace, _
        olSourceFolder As MAPIFolder, _
        olDestinationFolder As MAPIFolder, _
        olItems As Outlook.Items, _
        olContact As ContactItem, _
        olContactCopy As ContactItem, _
        intCounter As Integer
    Set olNS = olApp.GetNamespace("MAPI")
    'Replace Outlook below with your profile name
    olNS.Logon "Outlook"
    'Replace the path below with the path to the source folder
    Set olSourceFolder = OpenMAPIFolder("\Public Folders\All Public Folders\EEFolders\TestContacts")
    'Replace the path below with the path to the destination folder
    Set olDestinationFolder = OpenMAPIFolder("\Mailbox - BlueDevilFan\MyContacts")
    Set olItems = olSourceFolder.Items
    For Each olContact In olItems
        Set olContactCopy = olContact.Copy
        olContactCopy.Move olDestinationFolder
    Set olContact = Nothing
    Set olContactCopy = Nothing
    Set olSourceFolder = Nothing
    Set olDestinationFolder = Nothing
    Set olItems = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

' Credit where credit is due.  The code below is not mine.  I picked it up somewhere on the internet.  I don't remember
' where or who wrote it, but whoever the author is deserves the credit, not me.
Function OpenMAPIFolder(ByVal szPath As String) As Outlook.MAPIFolder
    Dim app As New Outlook.Application
    Dim ns As Outlook.NameSpace
    Dim flr As Outlook.MAPIFolder
    Dim szDir As String
    Dim i As Long
    Set app = New Outlook.Application

    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
        Set flr = app.ActiveExplorer.CurrentFolder
    End If

    While szPath <> ""
        i = InStr(szPath, "\")

        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
            szDir = szPath
            szPath = ""
        End If

        If flr Is Nothing Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
            Set flr = flr.Folders(szDir)
        End If


    Set OpenMAPIFolder = flr
End Function
slangdellAuthor Commented:
Thanks for this. I am in the middle of a project and haven't had a chance to try it out. When I do, I will update and close this out!


It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.