Outlook 2010 - VBA to copy Public Folder Contacts to Mailbox-Contacts subfolder II

Why do you need to modify it.  If it worked in Outlook 2003, why does it not work in Outlook  2010?

Hi, MisUszatek.

@shorvath is correct.  I wrote that code.  It should work fine in Outlook 2010.

I get the following error message:

Run-time error '-2147221233 (8004010f)'
The attempted operation failed. An object could not be found.

When I run the debugger it highlights the following line:

Set flr = ns.Folders(szDir)

The folder path is probably invalid.  Can you share what it is?

Set olkSource = OpenMAPIFolder("\Public Folders\All Public Folders\LB office\BB-LIST")

Set olkDest = OpenMAPIFolder("\Mailbox - " & varMailbox & "\Contacts\BB-Listr")

Set olkDest = OpenMAPIFolder("\Mailbox - " & varMailbox & "\Contacts")

in Outlook 2010 i do not see "Mailbox - Full Name" like it was in Outlook 2003. Instead there is an email address, does this make any difference? I changed \Mailbox - " & varMailbox & "  to my email but this didn't help

Can you post a screenshot showing your folder structure?

folder structure of my inbox?

attached
2013-02-08-164723.png

here is the full folder list structure
2013-02-08-165042.png

Are you including the word "Mailbox" in the folder path?  From the screenshot it appears that the path should be something like "MisUszatek@company.com\Contacts\BB-Listr" where "MisUszatek@company.com" is your actual email address.

I was able to figureout what i was doing wrong... Is there any way you could modify this scrip the way it copies all content from a specific Public Folder to users contacts but without a subfolders?

for example:
\Public Folders\Corporate Contacts\
- item 1
- item 2
...
item x

will be copied to
\user@company.com\contacts\
- item 1
- item 2
...
item x

The script must be overwrite all existing items in the user's contacts folder

I can manage that.  Is this the code you're using?

Sub CopyContactFolder()
    Dim olkSource As Outlook.MAPIFolder, _
        olkDest As Outlook.MAPIFolder, _
        arrMailboxes As Variant, _
        varMailbox As Variant
    'Edit the list of mailbox names on the following line.
    arrMailboxes = Split("kent, clark;lane, lois;white, perry", ";")
    Set olkSource = OpenMAPIFolder("\Public Folders\All Public Folders\Contacts Folder")
    For Each varMailbox In arrMailboxes
        'Change the folder path on the following line as needed.
        Set olkDest = OpenMAPIFolder("\Mailbox - " & varMailbox & "\Contacts\Contacts Folder")
        olkDest.Delete
        Set olkDest = OpenMAPIFolder("\Mailbox - " & varMailbox & "\Contacts")
        olkSource.CopyTo olkDest
    Next
    Set olkDest = Nothing
    Set olkSource = Nothing
End Sub

Select allOpen in new window

I use this code:
Sub CopyContactFolder()
    Dim olkSource As Outlook.MAPIFolder, _
        olkDest As Outlook.MAPIFolder, _
        arrMailboxes As Variant, _
        varMailbox As Variant
    'Edit the list of mailbox names on the following line.
    arrMailboxes = Split("user1@company.com; user2@company.com", ";")
    Set olkSource = OpenMAPIFolder("\Public Folders - user@company.com\All Public Folders\Corporate Contacts")
    For Each varMailbox In arrMailboxes
        'Change the folder path on the following line as needed.
        Set olkDest = OpenMAPIFolder("\" & varMailbox & "\Contacts\Corporate Contacts")
        olkDest.Delete
        Set olkDest = OpenMAPIFolder("\" & varMailbox & "\Contacts")
        olkSource.CopyTo olkDest
    Next
    Set olkDest = Nothing
    Set olkSource = Nothing
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(ByVal szPath As String)
    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

Hi there again,
Actually i came up with a better idea. Instead overwriting existing contacts, the script should delete all contacts withihn a specific cattegory for example all corporate contacts in public folders will have a category set to "Corpoprate Contacts". The script first should delete all contacts with this category then it should copy back all the contacts from the Public Folders. This way if we delete/update/rename something in Public Folders it will be deleted in first place from user's contacts and then a new items will be copied again.

I went back through this question and I'm a little confused.  The code copies an folder called "Corporate Contacts" from a public folder to a sub-folder under contacts.  Before doing this it deletes the "Corporate Contacts" sub-folder to ensure that there's no chance of duplicates.  

I must not understand where you want to copy the contacts to.  Please help me understand how you want this to work.

I simply need another script which will not be copying a whole folder into a subfolder but instead will copy all contacts from public folder into the user's contacts root folder.

The reason i need to copy contacts items itself without creating subfolders is that the adnroid phones do not support syncing contacts subfolders. Active sync only syncs all contacts included in the main user's contacts root folder.
see this for more details: http://code.google.com/p/android/issues/detail?id=8045&q=contacts%20subfolders&colspec=ID%20Type%20Status%20Owner%20Summary%20Stars

To be able to distinguish between user's personal contacts and company contacts i would like to use categories. All company contacts would have a category "Corporate Contacts" and the script should simply first delete these contacts from user's contact list and then should copy back updated contacts from Public Folders

This is exactly what i need thank you very much!

One more questions... is there any way the script will hard delete (like Shift+Delete in Outlook) all items so they do not end up in my deleted items folder?

There is no command for doing a hard-delete.  The only way I know of to accomplish that in code is to delete the item then go to Deleted Items and delete it again.  I can add code for emptying deleted items once the process has ended.  Would you like me to do that?

sure if you can please