Solved

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

Posted on 2013-01-17
24
1,293 Views
Last Modified: 2013-06-25
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
Comment
Question by:MisUszatek
  • 15
  • 8
24 Comments
 
LVL 9

Expert Comment

by:shorvath
Comment Utility
Why do you need to modify it.  If it worked in Outlook 2003, why does it not work in Outlook  2010?
0
 
LVL 76

Expert Comment

by:David Lee
Comment Utility
Hi, MisUszatek.

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

Author Comment

by:MisUszatek
Comment Utility
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
 
LVL 76

Expert Comment

by:David Lee
Comment Utility
The folder path is probably invalid.  Can you share what it is?
0
 

Author Comment

by:MisUszatek
Comment Utility
Set olkSource = OpenMAPIFolder("\Public Folders\All Public Folders\LB office\BB-LIST")
0
 

Author Comment

by:MisUszatek
Comment Utility
Set olkDest = OpenMAPIFolder("\Mailbox - " & varMailbox & "\Contacts\BB-Listr")
0
 

Author Comment

by:MisUszatek
Comment Utility
Set olkDest = OpenMAPIFolder("\Mailbox - " & varMailbox & "\Contacts")
0
 

Author Comment

by:MisUszatek
Comment Utility
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
 
LVL 76

Expert Comment

by:David Lee
Comment Utility
Can you post a screenshot showing your folder structure?
0
 

Author Comment

by:MisUszatek
Comment Utility
folder structure of my inbox?
0
 

Author Comment

by:MisUszatek
Comment Utility
0
 

Author Comment

by:MisUszatek
Comment Utility
here is the full folder list structure
2013-02-08-165042.png
0
Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

 
LVL 76

Expert Comment

by:David Lee
Comment Utility
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
 

Author Comment

by:MisUszatek
Comment Utility
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
 
LVL 76

Expert Comment

by:David Lee
Comment Utility
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
 

Author Comment

by:MisUszatek
Comment Utility
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
 

Author Comment

by:MisUszatek
Comment Utility
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
 
LVL 76

Expert Comment

by:David Lee
Comment Utility
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
 

Author Comment

by:MisUszatek
Comment Utility
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
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
Comment Utility
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
 

Author Comment

by:MisUszatek
Comment Utility
This is exactly what i need thank you very much!
0
 

Author Comment

by:MisUszatek
Comment Utility
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
 
LVL 76

Expert Comment

by:David Lee
Comment Utility
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
 

Author Comment

by:MisUszatek
Comment Utility
sure if you can please
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Granting full access permission allows users to access mailboxes present in their database. By giving full access permission one can open and read the content of any mailbox but cannot send emails from that mailbox.
Get an idea of what you should include in an email disclaimer with these Top 5 email disclaimer tips.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…

763 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

16 Experts available now in Live!

Get 1:1 Help Now