Improve company productivity with a Business Account.Sign Up

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 564
  • Last Modified:

Sync Public Contact folders with Private Contact folders

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
Bi-Con
Asked:
Bi-Con
  • 9
  • 9
1 Solution
 
David LeeCommented:
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
 
Bi-ConAuthor Commented:
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
 
David LeeCommented:
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
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Bi-ConAuthor Commented:
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
 
Bi-ConAuthor Commented:
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
 
David LeeCommented:
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
 
Bi-ConAuthor Commented:
That code fixed line 16, but Im still getting the following error

Error:     Type mismatch: 'OpenOutlookFolder'
Code:     800A000D
Source:  Microsoft VBScript runtime error
0
 
David LeeCommented:
Change OpenOutlookFolder to OpenMAPIFolder
0
 
Bi-ConAuthor Commented:
Genius!!!

Now there is an error on line 25:

Error:          The property "FileAs" is unknown
Code:          80020009
Source:       Microsoft Office Outlook
0
 
David LeeCommented:
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
 
Bi-ConAuthor Commented:
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
 
David LeeCommented:
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
 
David LeeCommented:
Just to confirm, you are running this on Outlook 2003, right?
0
 
Bi-ConAuthor Commented:
Yes I am running Outlook 2003 SP3
0
 
Bi-ConAuthor Commented:
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
 
David LeeCommented:
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
 
Bi-ConAuthor Commented:
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
 
David LeeCommented:
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
 
StaudteCommented:
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
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.

Join & Write a Comment

Featured Post

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

  • 9
  • 9
Tackle projects and never again get stuck behind a technical roadblock.
Join Now