Public contacts to private contacts sync issue

I've been working on finding a solution to this for a couple of days now and have had no luck. The issue is that our client needs a one way sync to go from his public contacts to a subfolder in his private contacts so he can access them via his Iphone. As suggested on EE, I tried to deploy Add2Exchange but it has caused nothing but a head ache. The program has issues with server 2008 and refuses to work for me. Trying to get help from tech support is nothing but them trying to sell me a $150 installation. The second thought was to create a macro and have it run whenever he open's outlook, not a true sync but will work since his contacts rarely update. This was unacceptable for him as he does not want to wait the minute the macro takes to run (The public folder has quite a large number of contacts).

Now we are at the point where I'd like the macro to either run as a vbs script every so often on the terminal server, or since we have an account that stays open all the time on the terminal server, leave outlook open and set the macro to run on a timed interval on his mailbox. I can't seem to get around the "A program is trying to access e-mail address information stored in Outlook." message. I've tried using Redemption and digitally signing my macro, neither of which worked. I am not particularly fond of the idea of installing ClickYes.

What I need help with is basically finding a way for this to run without him being aware its running.

Here is the macro I've pieced together from EE:

Thank you
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 = OpenMAPIFolder("\\Contacts\APX Contacts")
    'Edit the path to the shared folder as needed
    Set objSharedFolder = OpenMAPIFolder("\Public Folders -\All Public Folders\testcontacts")

    '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
                '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
       For intIndex = objLocalFolder.Items.Count To 1 Step -1
        Set objContact = objLocalFolder.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 = objSharedFolder.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
                '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
    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
    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)
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
            Set flr = flr.Folders(szDir)
        End If
    Set OpenMAPIFolder = flr
End Function
Function IsNothing(Obj)
  If TypeName(Obj) = "Nothing" Then
    IsNothing = True
    IsNothing = False
  End If
End Function
'Code Ends Here

Open in new window

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

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

David LeeCommented:
Hi, cybersharks1.

You should not get any warning messages in Outlook 2007 if anti-virus is installed.  Is an anti-virus package installed and has Outlook security been set to allow code to run without warnings?  You can check both by clicking Tools > Trust Center and selecting the "Programmatic Access" option in the left-hand panel.

Experts Exchange Solution brought to you by

Your issues matter to us.

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

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

From novice to tech pro — start learning today.