Solved

Sync Public Contact folders with Private Contact folders

Posted on 2007-11-27
21
556 Views
Last Modified: 2011-10-03
Hello.  I am trying to write a macro that will copy any Contacts from Public folder A to a private folder B so that users have access to up to date Public folder contacts on their Treo phones while on the road.  Thanks in advance!
0
Comment
Question by:Bi-Con
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 9
  • 9
21 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 20362267
Hi, Bi-Con.

Give this a try.  It does a one-way sync from a shared folder to a private contacts folder.  I've tested using Outlook 2003 and it works perfectly.
Sub SyncContacts()
    Dim objLocalFolder As MAPIFolder, _
        objSharedFolder As MAPIFolder, _
        objContact As Object, _
        objContactCopy As Object, _
        intIndex As Integer, _
        intItemsSynced As Integer, _
        intItemsCopied As Integer
    'Set a couple of variables
    intItemsSynced = 0
    intItemsCopied = 0
    'The local folder is the default contacts folder
    Set objLocalFolder = Session.GetDefaultFolder(olFolderContacts)
    'Edit the path to the shared folder as needed
    Set objSharedFolder = OpenOutlookFolder("\Public Folders\All Public Folders\Contacts\eeTest")
    'Process each item in the shared folder
    For intIndex = objSharedFolder.Items.Count To 1 Step -1
        Set objContact = objSharedFolder.Items.Item(intIndex)
        'Is this item a contact
        If objContact.Class = olContact Then
            'Check for a matching contact in the local contacts folder
            Set objContactCopy = objLocalFolder.Items.Find("[FileAs] = " & Chr(34) & objContact.FileAs & Chr(34))
            'Did we find a match
            If Not IsNothing(objContactCopy) Then
                'If yes, copy from shared to local
                ContactCopy objContact, objContactCopy
                intItemsSynced = intItemsSynced + 1
            Else
                'If no, make a copy and move it to local
                Set objContactCopy = objContact.Copy
                objContactCopy.Move objLocalFolder
                intItemsCopied = intItemsCopied + 1
            End If
        End If
    Next
    Set objContact = Nothing
    Set objContactCopy = Nothing
    Set objLocalFolder = Nothing
    Set objSharedFolder = Nothing
    MsgBox "Synced: " & intItemsSynced & vbCrLf _
         & "Copied: " & intItemsCopied, vbInformation + vbOKOnly, "Contact Sync"
End Sub
 
Private Sub ContactCopy(objSourceItem As ContactItem, objDestItem As ContactItem)
    With objSourceItem
        objDestItem.Account = .Account
        objDestItem.Anniversary = .Anniversary
        objDestItem.AssistantName = .AssistantName
        objDestItem.AssistantTelephoneNumber = .AssistantTelephoneNumber
        objDestItem.BillingInformation = .BillingInformation
        objDestItem.Birthday = .Birthday
        objDestItem.Body = .Body
        objDestItem.Business2TelephoneNumber = .Business2TelephoneNumber
        objDestItem.BusinessAddress = .BusinessAddress
        objDestItem.BusinessAddressCity = .BusinessAddressCity
        objDestItem.BusinessAddressCountry = .BusinessAddressCountry
        objDestItem.BusinessAddressPostalCode = .BusinessAddressPostalCode
        objDestItem.BusinessAddressPostOfficeBox = .BusinessAddressPostOfficeBox
        objDestItem.BusinessAddressState = .BusinessAddressState
        objDestItem.BusinessAddressStreet = .BusinessAddressStreet
        objDestItem.BusinessFaxNumber = .BusinessFaxNumber
        objDestItem.BusinessHomePage = .BusinessHomePage
        objDestItem.BusinessTelephoneNumber = .BusinessTelephoneNumber
        objDestItem.CallbackTelephoneNumber = .CallbackTelephoneNumber
        objDestItem.CarTelephoneNumber = .CarTelephoneNumber
        objDestItem.Categories = .Categories
        objDestItem.Children = .Children
        objDestItem.Companies = .Companies
        objDestItem.Department = .Department
        objDestItem.Email1Address = .Email1Address
        objDestItem.Email1AddressType = .Email1AddressType
        objDestItem.Email1DisplayName = .Email1DisplayName
        objDestItem.Email2Address = .Email2Address
        objDestItem.Email2AddressType = .Email2AddressType
        objDestItem.Email2DisplayName = .Email2DisplayName
        objDestItem.Email3Address = .Email3Address
        objDestItem.Email3AddressType = .Email3AddressType
        objDestItem.Email3DisplayName = .Email3DisplayName
        objDestItem.FileAs = .FileAs
        objDestItem.FTPSite = .FTPSite
        objDestItem.FullName = .FullName
        objDestItem.Gender = .Gender
        objDestItem.GovernmentIDNumber = .GovernmentIDNumber
        objDestItem.Hobby = .Hobby
        objDestItem.Home2TelephoneNumber = .Home2TelephoneNumber
        objDestItem.HomeAddress = .HomeAddress
        objDestItem.HomeAddressCity = .HomeAddressCity
        objDestItem.HomeAddressCountry = .HomeAddressCountry
        objDestItem.HomeAddressPostalCode = .HomeAddressPostalCode
        objDestItem.HomeAddressPostOfficeBox = .HomeAddressPostOfficeBox
        objDestItem.HomeAddressState = .HomeAddressState
        objDestItem.HomeAddressStreet = .HomeAddressStreet
        objDestItem.HomeFaxNumber = .HomeFaxNumber
        objDestItem.HomeTelephoneNumber = .HomeTelephoneNumber
        objDestItem.IMAddress = .IMAddress
        objDestItem.Importance = .Importance
        objDestItem.Initials = .Initials
        objDestItem.InternetFreeBusyAddress = .InternetFreeBusyAddress
        objDestItem.ISDNNumber = .ISDNNumber
        objDestItem.JobTitle = .JobTitle
        objDestItem.Language = .Language
        objDestItem.LastName = .LastName
        objDestItem.MailingAddress = .MailingAddress
        objDestItem.MailingAddressCity = .MailingAddressCity
        objDestItem.MailingAddressCountry = .MailingAddressCountry
        objDestItem.MailingAddressPostalCode = .MailingAddressPostalCode
        objDestItem.MailingAddressPostOfficeBox = .MailingAddressPostOfficeBox
        objDestItem.MailingAddressState = .MailingAddressState
        objDestItem.MailingAddressStreet = .MailingAddressStreet
        objDestItem.ManagerName = .ManagerName
        objDestItem.MiddleName = .MiddleName
        objDestItem.Mileage = .Mileage
        objDestItem.MobileTelephoneNumber = .MobileTelephoneNumber
        objDestItem.NetMeetingAlias = .NetMeetingAlias
        objDestItem.NetMeetingServer = .NetMeetingServer
        objDestItem.NickName = .NickName
        objDestItem.OfficeLocation = .OfficeLocation
        objDestItem.OrganizationalIDNumber = .OrganizationalIDNumber
        objDestItem.OtherAddress = .OtherAddress
        objDestItem.OtherAddressCity = .OtherAddressCity
        objDestItem.OtherAddressCountry = .OtherAddressCountry
        objDestItem.OtherAddressPostalCode = .OtherAddressPostalCode
        objDestItem.OtherAddressPostOfficeBox = .OtherAddressPostOfficeBox
        objDestItem.OtherAddressState = .OtherAddressState
        objDestItem.OtherAddressStreet = .OtherAddressStreet
        objDestItem.OtherFaxNumber = .OtherFaxNumber
        objDestItem.OtherTelephoneNumber = .OtherTelephoneNumber
        objDestItem.PagerNumber = .PagerNumber
        objDestItem.PersonalHomePage = .PersonalHomePage
        objDestItem.PrimaryTelephoneNumber = .PrimaryTelephoneNumber
        objDestItem.Profession = .Profession
        objDestItem.RadioTelephoneNumber = .RadioTelephoneNumber
        objDestItem.ReferredBy = .ReferredBy
        objDestItem.SelectedMailingAddress = .SelectedMailingAddress
        objDestItem.Sensitivity = .Sensitivity
        objDestItem.Spouse = .Spouse
        objDestItem.Subject = .Subject
        objDestItem.Suffix = .Suffix
        objDestItem.TelexNumber = .TelexNumber
        objDestItem.Title = .Title
        objDestItem.TTYTDDTelephoneNumber = .TTYTDDTelephoneNumber
        objDestItem.User1 = .User1
        objDestItem.User2 = .User2
        objDestItem.User3 = .User3
        objDestItem.WebPage = .WebPage
        objDestItem.Save
    End With
End Sub
 
'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        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("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
End Function
 
Function IsNothing(Obj)
  If TypeName(Obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function
'Code Ends Here

Open in new window

0
 

Author Comment

by:Bi-Con
ID: 20365127
Thanks for the response BlueDevilFan!  Ill test this code in Outlook.  Another question I have is:  Is it possible to schedule this to run at a certain time either in Outlook, or on a script scheduled with Windows Task Manager?
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20372458
Bi-Con,

Try this.  It's a VBScript version of what I posted above.  It is suitable for running from Windows Task Manager.  At the moment I'm not on a computer with access to Exchange, so I haven't tested the script to ensure that there aren't any mistakes.  
Const olContact = 40
Dim objApp, objSession, objLocalFolder, objSharedFolder, objContact, objContactCopy, intIndex, bolLogoff
'Is Outlook already running?
Set objApp = GetObject(,"Outlook.Application")
If it isn't, then launch it and logon to the default profile
If TypeName(objApp) <> "Application" Then
    Set objApp = CreateObject("Outlook.Application")
    Set objSession = objApp.Session
    'Change the profile name on the following line as needed
    objSession.Logon "ProfileName"
    bolLogoff = True
Else
    Set objSession = objApp.Session
End If
'The local folder is the default contacts folder
Set objLocalFolder = objSession.GetDefaultFolder(olFolderContacts)
'Edit the path to the shared folder as needed
Set objSharedFolder = OpenOutlookFolder("\Public Folders\All Public Folders\Contacts\eeTest")
'Process each item in the shared folder
For intIndex = objSharedFolder.Items.Count To 1 Step -1
    Set objContact = objSharedFolder.Items.Item(intIndex)
    'Is this item a contact
    If objContact.Class = olContact Then
        'Check for a matching contact in the local contacts folder
        Set objContactCopy = objLocalFolder.Items.Find("[FileAs] = " & Chr(34) & objContact.FileAs & Chr(34))
        'Did we find a match
        If Not IsNothing(objContactCopy) Then
            'If yes, copy from shared to local
            ContactCopy objContact, objContactCopy
        Else
            'If no, make a copy and move it to local
            Set objContactCopy = objContact.Copy
            objContactCopy.Move objLocalFolder
        End If
    End If
Next
Set objContact = Nothing
Set objContactCopy = Nothing
Set objLocalFolder = Nothing
Set objSharedFolder = Nothing
If bolLogoff Then
    objSession.Logoff
End If
Set objSession = Nothing
Set objApp = Nothing
WScript.Quit
 
Private Sub ContactCopy(objSourceItem, objDestItem)
    With objSourceItem
        objDestItem.Account = .Account
        objDestItem.Anniversary = .Anniversary
        objDestItem.AssistantName = .AssistantName
        objDestItem.AssistantTelephoneNumber = .AssistantTelephoneNumber
        objDestItem.BillingInformation = .BillingInformation
        objDestItem.Birthday = .Birthday
        objDestItem.Body = .Body
        objDestItem.Business2TelephoneNumber = .Business2TelephoneNumber
        objDestItem.BusinessAddress = .BusinessAddress
        objDestItem.BusinessAddressCity = .BusinessAddressCity
        objDestItem.BusinessAddressCountry = .BusinessAddressCountry
        objDestItem.BusinessAddressPostalCode = .BusinessAddressPostalCode
        objDestItem.BusinessAddressPostOfficeBox = .BusinessAddressPostOfficeBox
        objDestItem.BusinessAddressState = .BusinessAddressState
        objDestItem.BusinessAddressStreet = .BusinessAddressStreet
        objDestItem.BusinessFaxNumber = .BusinessFaxNumber
        objDestItem.BusinessHomePage = .BusinessHomePage
        objDestItem.BusinessTelephoneNumber = .BusinessTelephoneNumber
        objDestItem.CallbackTelephoneNumber = .CallbackTelephoneNumber
        objDestItem.CarTelephoneNumber = .CarTelephoneNumber
        objDestItem.Categories = .Categories
        objDestItem.Children = .Children
        objDestItem.Companies = .Companies
        objDestItem.Department = .Department
        objDestItem.Email1Address = .Email1Address
        objDestItem.Email1AddressType = .Email1AddressType
        objDestItem.Email1DisplayName = .Email1DisplayName
        objDestItem.Email2Address = .Email2Address
        objDestItem.Email2AddressType = .Email2AddressType
        objDestItem.Email2DisplayName = .Email2DisplayName
        objDestItem.Email3Address = .Email3Address
        objDestItem.Email3AddressType = .Email3AddressType
        objDestItem.Email3DisplayName = .Email3DisplayName
        objDestItem.FileAs = .FileAs
        objDestItem.FTPSite = .FTPSite
        objDestItem.FullName = .FullName
        objDestItem.Gender = .Gender
        objDestItem.GovernmentIDNumber = .GovernmentIDNumber
        objDestItem.Hobby = .Hobby
        objDestItem.Home2TelephoneNumber = .Home2TelephoneNumber
        objDestItem.HomeAddress = .HomeAddress
        objDestItem.HomeAddressCity = .HomeAddressCity
        objDestItem.HomeAddressCountry = .HomeAddressCountry
        objDestItem.HomeAddressPostalCode = .HomeAddressPostalCode
        objDestItem.HomeAddressPostOfficeBox = .HomeAddressPostOfficeBox
        objDestItem.HomeAddressState = .HomeAddressState
        objDestItem.HomeAddressStreet = .HomeAddressStreet
        objDestItem.HomeFaxNumber = .HomeFaxNumber
        objDestItem.HomeTelephoneNumber = .HomeTelephoneNumber
        objDestItem.IMAddress = .IMAddress
        objDestItem.Importance = .Importance
        objDestItem.Initials = .Initials
        objDestItem.InternetFreeBusyAddress = .InternetFreeBusyAddress
        objDestItem.ISDNNumber = .ISDNNumber
        objDestItem.JobTitle = .JobTitle
        objDestItem.Language = .Language
        objDestItem.LastName = .LastName
        objDestItem.MailingAddress = .MailingAddress
        objDestItem.MailingAddressCity = .MailingAddressCity
        objDestItem.MailingAddressCountry = .MailingAddressCountry
        objDestItem.MailingAddressPostalCode = .MailingAddressPostalCode
        objDestItem.MailingAddressPostOfficeBox = .MailingAddressPostOfficeBox
        objDestItem.MailingAddressState = .MailingAddressState
        objDestItem.MailingAddressStreet = .MailingAddressStreet
        objDestItem.ManagerName = .ManagerName
        objDestItem.MiddleName = .MiddleName
        objDestItem.Mileage = .Mileage
        objDestItem.MobileTelephoneNumber = .MobileTelephoneNumber
        objDestItem.NetMeetingAlias = .NetMeetingAlias
        objDestItem.NetMeetingServer = .NetMeetingServer
        objDestItem.NickName = .NickName
        objDestItem.OfficeLocation = .OfficeLocation
        objDestItem.OrganizationalIDNumber = .OrganizationalIDNumber
        objDestItem.OtherAddress = .OtherAddress
        objDestItem.OtherAddressCity = .OtherAddressCity
        objDestItem.OtherAddressCountry = .OtherAddressCountry
        objDestItem.OtherAddressPostalCode = .OtherAddressPostalCode
        objDestItem.OtherAddressPostOfficeBox = .OtherAddressPostOfficeBox
        objDestItem.OtherAddressState = .OtherAddressState
        objDestItem.OtherAddressStreet = .OtherAddressStreet
        objDestItem.OtherFaxNumber = .OtherFaxNumber
        objDestItem.OtherTelephoneNumber = .OtherTelephoneNumber
        objDestItem.PagerNumber = .PagerNumber
        objDestItem.PersonalHomePage = .PersonalHomePage
        objDestItem.PrimaryTelephoneNumber = .PrimaryTelephoneNumber
        objDestItem.Profession = .Profession
        objDestItem.RadioTelephoneNumber = .RadioTelephoneNumber
        objDestItem.ReferredBy = .ReferredBy
        objDestItem.SelectedMailingAddress = .SelectedMailingAddress
        objDestItem.Sensitivity = .Sensitivity
        objDestItem.Spouse = .Spouse
        objDestItem.Subject = .Subject
        objDestItem.Suffix = .Suffix
        objDestItem.TelexNumber = .TelexNumber
        objDestItem.Title = .Title
        objDestItem.TTYTDDTelephoneNumber = .TTYTDDTelephoneNumber
        objDestItem.User1 = .User1
        objDestItem.User2 = .User2
        objDestItem.User3 = .User3
        objDestItem.WebPage = .WebPage
        objDestItem.Save
    End With
End Sub
 
'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        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("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
End Function
 
Function IsNothing(Obj)
  If TypeName(Obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function
'Code Ends Here

Open in new window

0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:Bi-Con
ID: 20381915
I ran the script to start debugging.  Line 5 needed a ' for the comment but I couldnt get line 16 and 18 figured out!!  It kept telling me that one or more parameters was invalid!  Please help!  Thanks!
0
 

Author Comment

by:Bi-Con
ID: 20382164
These sites say something about not being able to pass named constants into .GetDefaultFolder and I have to use .GetDefaultFolder(9)  but I do not understand what (9) is?  Thanks!
http://msdn2.microsoft.com/en-us/library/aa220100(office.11).aspx
http://msdn2.microsoft.com/en-us/library/aa158264(office.10).aspx
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20384063
Add this line

    Const olFolderContacts = 10

at the top of the script next to the other Const definition.

For line 18, you have to put in the path to your public folder.  The path will be something like "\Public Folders\All Public Folders\Some Folder Name\Possibly Some Sub-folder Name"
0
 

Author Comment

by:Bi-Con
ID: 20397936
That code fixed line 16, but Im still getting the following error

Error:     Type mismatch: 'OpenOutlookFolder'
Code:     800A000D
Source:  Microsoft VBScript runtime error
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20400247
Change OpenOutlookFolder to OpenMAPIFolder
0
 

Author Comment

by:Bi-Con
ID: 20402456
Genius!!!

Now there is an error on line 25:

Error:          The property "FileAs" is unknown
Code:          80020009
Source:       Microsoft Office Outlook
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20407403
I don't know how "FileAs" can be absent, but you can just comment out that line.  To turn a line of code into a comment simply prefix it with a single quote (i.e. ').
0
 

Author Comment

by:Bi-Con
ID: 20419279
Ok commenting out that line worked.  Thanks.  Now starting at line 50 I get this error:

Line:     50
Char:    9
Error:   Object required: 'objDestItem'
Code:   800A01A8
Source: MS VBS runtime error
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20423868
Let's go back to the previous error a minute.  I didn't notice the line number you listed there.  I saw the error message and thought the error was on line 83 where the FileAs property is being copied.  If you commented out line #25, then that's the cause of the current error.  We need to go back and reactivate line #25, then we need to figure out why it's telling us that FileAs is an unknown property.  
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20424896
Just to confirm, you are running this on Outlook 2003, right?
0
 

Author Comment

by:Bi-Con
ID: 20427570
Yes I am running Outlook 2003 SP3
0
 

Author Comment

by:Bi-Con
ID: 20445586
I uncommented line 25, but obviously the error about 'FileAs' is still occuring.  I have tried a couple looking in of different places, but I cannot find why it is throwing an error.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 20446144
That's what has me stumped.  FileAs is a built-in property of all contact items.  It has to be there.  I also tested the code on a computer with Outlook 2003 and it worked perfectly.  Try this as a test.  Add the code below to what you already have.  Select one fo the contacts and run this macro.  It should display the FileAs property for the selected item.
Sub DisplayFileAs()
    Dim olkContact As Outlook.ContactItem
    Set olkContact = Application.ActiveExplorer.Selection(1)
    MsgBox olkContact.FileAs, vbOKOnly + vbInformation, "Display FileAs"
    Set olkContact = Nothing
End Sub

Open in new window

0
 

Author Comment

by:Bi-Con
ID: 20499259
What service pack are you using with Outlook 2003?  And how are you running the code?  Right now I have my code in a file named Contacts.vbs and I just double click it from my desktop to run it.  Am I trying to run it wrong?  Is there another way I should be running this?  Thanks!
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 20499400
I'm on SP3 too and I'm running the code from a vbs file also.  No, you're running it right.  The lst little script I posted for testing does need to be run from inside of Outlook though, not from a vbs file.  If you want to run it from outside of Outlook, then use this version instead.
Dim olkContact
Set olkContact = Application.ActiveExplorer.Selection(1)
MsgBox olkContact.FileAs, vbOKOnly + vbInformation, "Display FileAs"
Set olkContact = Nothing

Open in new window

0
 

Expert Comment

by:Staudte
ID: 25133940
Bluedevilfan,

thanks a lot for the code. This helped me a lot and it worked perferctly well on Outlook 2007, either from within Outlook or from a VBS script. I have incorporated the fixes you have come up with and added some simple code to add a category "öffentlicher Kontakt" (german, meaning "public contact") to every such record. Also, I made the code start automatically when Outlook starts.

For completeness, I attach the final version of this Outlook VBA code.

Best regards,
Thomas
Public Sub Application_Startup()
  SyncContacts
End Sub
 
Sub SyncContacts()
    Dim objLocalFolder As MAPIFolder, _
        objSharedFolder As MAPIFolder, _
        objContact As Object, _
        objContactCopy As Object, _
        intIndex As Integer
        
    'The local folder is the default contacts folder
    Set objLocalFolder = Session.GetDefaultFolder(olFolderContacts)
    'Edit the path to the shared folder as needed
    Set objSharedFolder = OpenMAPIFolder("\Öffentliche Ordner\Alle Öffentlichen Ordner\adr")
    
    'Process each item in the shared folder
    For intIndex = objSharedFolder.Items.Count To 1 Step -1
        Set objContact = objSharedFolder.Items.Item(intIndex)
        'Is this item a contact
        If objContact.Class = olContact Then
            'Check for a matching contact in the local contacts folder
            Set objContactCopy = objLocalFolder.Items.Find("[FileAs] = " & Chr(34) & objContact.FileAs & Chr(34))
            'Did we find a match
            If Not IsNothing(objContactCopy) Then
                'If yes, copy from shared to local
                ContactCopy objContact, objContactCopy
            Else
                'If no, make a copy and move it to local
                Set objContactCopy = objContact.Copy
                objContactCopy.Move objLocalFolder
                Set objContactCopy = objLocalFolder.Items.Find("[FileAs] = " & Chr(34) & objContact.FileAs & Chr(34))
                ContactCopy objContact, objContactCopy
            End If
        End If
    Next
    Set objContact = Nothing
    Set objContactCopy = Nothing
    Set objLocalFolder = Nothing
    Set objSharedFolder = Nothing
End Sub
 
Private Sub ContactCopy(objSourceItem As ContactItem, objDestItem As ContactItem)
    With objSourceItem
        objDestItem.Account = .Account
        objDestItem.Anniversary = .Anniversary
        objDestItem.AssistantName = .AssistantName
        objDestItem.AssistantTelephoneNumber = .AssistantTelephoneNumber
        objDestItem.BillingInformation = .BillingInformation
        objDestItem.Birthday = .Birthday
        objDestItem.Body = .Body
        objDestItem.Business2TelephoneNumber = .Business2TelephoneNumber
        objDestItem.BusinessAddress = .BusinessAddress
        objDestItem.BusinessAddressCity = .BusinessAddressCity
        objDestItem.BusinessAddressCountry = .BusinessAddressCountry
        objDestItem.BusinessAddressPostalCode = .BusinessAddressPostalCode
        objDestItem.BusinessAddressPostOfficeBox = .BusinessAddressPostOfficeBox
        objDestItem.BusinessAddressState = .BusinessAddressState
        objDestItem.BusinessAddressStreet = .BusinessAddressStreet
        objDestItem.BusinessFaxNumber = .BusinessFaxNumber
        objDestItem.BusinessHomePage = .BusinessHomePage
        objDestItem.BusinessTelephoneNumber = .BusinessTelephoneNumber
        objDestItem.CallbackTelephoneNumber = .CallbackTelephoneNumber
        objDestItem.CarTelephoneNumber = .CarTelephoneNumber
        objDestItem.Categories = .Categories & IIf(InStr(.Categories, "öffentlicher Kontakt") = 0, IIf(.Categories <> "", ";", "") & "öffentlicher Kontakt", "")
        objDestItem.Children = .Children
        objDestItem.Companies = .Companies
        objDestItem.Department = .Department
        objDestItem.Email1Address = .Email1Address
        objDestItem.Email1AddressType = .Email1AddressType
        objDestItem.Email1DisplayName = .Email1DisplayName
        objDestItem.Email2Address = .Email2Address
        objDestItem.Email2AddressType = .Email2AddressType
        objDestItem.Email2DisplayName = .Email2DisplayName
        objDestItem.Email3Address = .Email3Address
        objDestItem.Email3AddressType = .Email3AddressType
        objDestItem.Email3DisplayName = .Email3DisplayName
        objDestItem.FileAs = .FileAs
        objDestItem.FTPSite = .FTPSite
        objDestItem.FullName = .FullName
        objDestItem.Gender = .Gender
        objDestItem.GovernmentIDNumber = .GovernmentIDNumber
        objDestItem.Hobby = .Hobby
        objDestItem.Home2TelephoneNumber = .Home2TelephoneNumber
        objDestItem.HomeAddress = .HomeAddress
        objDestItem.HomeAddressCity = .HomeAddressCity
        objDestItem.HomeAddressCountry = .HomeAddressCountry
        objDestItem.HomeAddressPostalCode = .HomeAddressPostalCode
        objDestItem.HomeAddressPostOfficeBox = .HomeAddressPostOfficeBox
        objDestItem.HomeAddressState = .HomeAddressState
        objDestItem.HomeAddressStreet = .HomeAddressStreet
        objDestItem.HomeFaxNumber = .HomeFaxNumber
        objDestItem.HomeTelephoneNumber = .HomeTelephoneNumber
        objDestItem.IMAddress = .IMAddress
        objDestItem.Importance = .Importance
        objDestItem.Initials = .Initials
        objDestItem.InternetFreeBusyAddress = .InternetFreeBusyAddress
        objDestItem.ISDNNumber = .ISDNNumber
        objDestItem.JobTitle = .JobTitle
        objDestItem.Language = .Language
        objDestItem.LastName = .LastName
        objDestItem.MailingAddress = .MailingAddress
        objDestItem.MailingAddressCity = .MailingAddressCity
        objDestItem.MailingAddressCountry = .MailingAddressCountry
        objDestItem.MailingAddressPostalCode = .MailingAddressPostalCode
        objDestItem.MailingAddressPostOfficeBox = .MailingAddressPostOfficeBox
        objDestItem.MailingAddressState = .MailingAddressState
        objDestItem.MailingAddressStreet = .MailingAddressStreet
        objDestItem.ManagerName = .ManagerName
        objDestItem.MiddleName = .MiddleName
        objDestItem.Mileage = .Mileage
        objDestItem.MobileTelephoneNumber = .MobileTelephoneNumber
        objDestItem.NetMeetingAlias = .NetMeetingAlias
        objDestItem.NetMeetingServer = .NetMeetingServer
        objDestItem.NickName = .NickName
        objDestItem.OfficeLocation = .OfficeLocation
        objDestItem.OrganizationalIDNumber = .OrganizationalIDNumber
        objDestItem.OtherAddress = .OtherAddress
        objDestItem.OtherAddressCity = .OtherAddressCity
        objDestItem.OtherAddressCountry = .OtherAddressCountry
        objDestItem.OtherAddressPostalCode = .OtherAddressPostalCode
        objDestItem.OtherAddressPostOfficeBox = .OtherAddressPostOfficeBox
        objDestItem.OtherAddressState = .OtherAddressState
        objDestItem.OtherAddressStreet = .OtherAddressStreet
        objDestItem.OtherFaxNumber = .OtherFaxNumber
        objDestItem.OtherTelephoneNumber = .OtherTelephoneNumber
        objDestItem.PagerNumber = .PagerNumber
        objDestItem.PersonalHomePage = .PersonalHomePage
        objDestItem.PrimaryTelephoneNumber = .PrimaryTelephoneNumber
        objDestItem.Profession = .Profession
        objDestItem.RadioTelephoneNumber = .RadioTelephoneNumber
        objDestItem.ReferredBy = .ReferredBy
        objDestItem.SelectedMailingAddress = .SelectedMailingAddress
        objDestItem.Sensitivity = .Sensitivity
        objDestItem.Spouse = .Spouse
        objDestItem.Subject = .Subject
        objDestItem.Suffix = .Suffix
        objDestItem.TelexNumber = .TelexNumber
        objDestItem.Title = .Title
        objDestItem.TTYTDDTelephoneNumber = .TTYTDDTelephoneNumber
        objDestItem.User1 = .User1
        objDestItem.User2 = .User2
        objDestItem.User3 = .User3
        objDestItem.WebPage = .WebPage
        objDestItem.Save
    End With
End Sub
 
'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        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("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
End Function
 
Function IsNothing(Obj)
  If TypeName(Obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function
'Code Ends Here

Open in new window

0

Featured Post

Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Read this checklist to learn more about the 15 things you should never include in an email signature.
Changing a few Outlook Options can help keep you organized!
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…
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…

632 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