• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1616
  • Last Modified:

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

Hi Experts,
Would someone be able to modify the script from my previous post so it will work in Outlook 2010 - http://www.experts-exchange.com/Programming/Languages/Visual_Basic/Q_22531423.html

Thank you
0
MisUszatek
Asked:
MisUszatek
  • 15
  • 8
1 Solution
 
shorvathCommented:
Why do you need to modify it.  If it worked in Outlook 2003, why does it not work in Outlook  2010?
0
 
David LeeCommented:
Hi, MisUszatek.

@shorvath is correct.  I wrote that code.  It should work fine in Outlook 2010.
0
 
MisUszatekAuthor Commented:
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)
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
David LeeCommented:
The folder path is probably invalid.  Can you share what it is?
0
 
MisUszatekAuthor Commented:
Set olkSource = OpenMAPIFolder("\Public Folders\All Public Folders\LB office\BB-LIST")
0
 
MisUszatekAuthor Commented:
Set olkDest = OpenMAPIFolder("\Mailbox - " & varMailbox & "\Contacts\BB-Listr")
0
 
MisUszatekAuthor Commented:
Set olkDest = OpenMAPIFolder("\Mailbox - " & varMailbox & "\Contacts")
0
 
MisUszatekAuthor Commented:
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
0
 
David LeeCommented:
Can you post a screenshot showing your folder structure?
0
 
MisUszatekAuthor Commented:
folder structure of my inbox?
0
 
MisUszatekAuthor Commented:
0
 
MisUszatekAuthor Commented:
here is the full folder list structure
2013-02-08-165042.png
0
 
David LeeCommented:
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.
0
 
MisUszatekAuthor Commented:
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
0
 
David LeeCommented:
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

Open in new window

0
 
MisUszatekAuthor Commented:
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
0
 
MisUszatekAuthor Commented:
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.
0
 
David LeeCommented:
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.
0
 
MisUszatekAuthor Commented:
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
0
 
David LeeCommented:
This should do it.  Replace the code you have now with the code below.  Edit the code as needed.  Run CopyCorporateContacts when you're ready.  This version deletes all contacts belonging to the category "Corporate Contacts" from the user's Contacts folder, then copies the contacts from the public folder to Contacts.  

Sub CopyCorporateContacts()
    Dim olkSrc As Outlook.MAPIFolder, _
        olkDst As Outlook.MAPIFolder, _
        arrMbx As Variant, _
        varMbx As Variant
    'Edit the list of mailbox names on the following line.
    arrMbx = Split("user1@company.com;user2@company.com", ";")
    Set olkSrc = OpenOutlookFolder("\Public Folders - user@company.com\All Public Folders\Corporate Contacts")
    For Each varMbx In arrMbx
        'Change the folder path on the following line as needed.
        Set olkDst = OpenOutlookFolder("\" & varMbx & "\Contacts")
        CopyContactsToFolder olkSrc, olkDst
    Next
    Set olkDst = Nothing
    Set olkSrc = Nothing
End Sub

Sub CopyContactsToFolder(olkSrc As Outlook.MAPIFolder, olkTgt As Outlook.MAPIFolder)
    Dim olkCon As Object, _
        olkCpy As Object, _
        arrCat As Variant, _
        varCat As Variant, _
        intCnt As Integer
    For intCnt = olkTgt.Items.Count To 1 Step -1
        Set olkCon = olkTgt.Items.Item(intCnt)
        If olkCon.Class = olContact Then
            arrCat = Split(olkCon.Categories, ",")
            For Each varCat In arrCat
                If varCat = "Corporate Contacts" Then
                    olkCon.Delete
                    Exit For
                End If
            Next
        End If
    Next
    For intCnt = olkSrc.Items.Count To 1 Step -1
        Set olkCon = olkSrc.Items.Item(intCnt)
        If olkCon.Class = olContact Then
            Set olkCpy = olkCon.Copy
            olkCpy.Move olkTgt
        End If
    Next
End Sub

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.
    ' Written: 4/24/2009
    ' Author:  David Lee
    ' Outlook: All versions
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Open in new window

0
 
MisUszatekAuthor Commented:
This is exactly what i need thank you very much!
0
 
MisUszatekAuthor Commented:
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?
0
 
David LeeCommented:
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?
0
 
MisUszatekAuthor Commented:
sure if you can please
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

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