Solved

Sync Public Contact folders with Private Contact folders

Posted on 2007-11-27
21
535 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
  • 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
 

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
Zoho SalesIQ

Hassle-free live chat software re-imagined for business growth. 2 users, always free.

 
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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Check out this infographic on what you need to make a good email signature that will work perfectly for your organization.
Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

760 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

21 Experts available now in Live!

Get 1:1 Help Now