Need VBA script to export and import public folder contact list

Posted on 2004-11-10
Last Modified: 2012-08-14
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.


Question by:slangdell
    LVL 76

    Accepted Solution

    Hi, Shawna.

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

    Expert Comment

    by:David Lee
    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

    Author Comment

    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!



    Featured Post

    Free Trending Threat Insights Every Day

    Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

    Join & Write a Comment

    Suggested Solutions

    Title # Comments Views Activity
    pop/imap email 32 33
    EXCHANGE 2007 4 37
    Search Outlook Items 13 26
    Sharing Inbox sub-folder in Oultook Connected to Office 365 3 0
    Get an idea of what you should include in an email disclaimer with these Top 5 email disclaimer tips.
    Create high volume marketing opportunities using email signatures with these top 10 DOs and DON'Ts of email signature marketing.
    This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
    To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

    754 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    23 Experts available now in Live!

    Get 1:1 Help Now