通过Excel VBA宏将Outlook共享联系人复制到MyContacts指定文件夹

问题背景 #

• 需求：通过Excel端运行的VBA宏，将Outlook共享联系人分类下「John Doe」文件夹内的所有联系人，自动复制到本地MyContacts/Another_Folder路径下
• 现有进度：已实现本地默认联系人文件夹到目标文件夹的复制逻辑，但无法定位共享联系人路径完成相同操作；宏部署在Excel侧，无需单独给用户配置Outlook宏权限
• 现有可用代码：

Sub CopyContacts()

Dim ContactItem As Outlook.ContactItem
Dim Name As Outlook.Namespace
Dim Folder As Outlook.Folder
Dim Item As Object

Set Name = Outlook.GetNamespace("MAPI")

Set Folder = Name.GetDefaultFolder(olFolderContacts)

For Each Item In Folder.Items

    If Item.Class = olContact Then

        Set ContactItem = Item.Copy
        ContactItem.Move Folder.Folders("Another_Folder")

    End If

Next

End Sub

• 参考文件夹结构：
  

修改后可直接运行的代码 #

共享联系人不属于当前用户的默认MAPI存储，无法通过GetDefaultFolder方法直接获取，需要遍历Outlook已加载的所有存储定位目标共享文件夹。

前置操作：打开Excel VBA编辑器，点击「工具-引用」，勾选Microsoft Outlook XX.X Object Library（XX.X为你本机安装的Office版本号）

Sub CopySharedContacts()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olTargetFolder As Outlook.Folder
    Dim olStore As Outlook.Store
    Dim olContactRoot As Outlook.Folder
    Dim olSourceFolder As Outlook.Folder
    Dim Item As Object
    Dim copiedContact As Outlook.ContactItem
    
    ' 兼容Outlook打开/未打开状态
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    Set olNS = olApp.GetNamespace("MAPI")
    ' 定位本地目标文件夹
    Set olTargetFolder = olNS.GetDefaultFolder(olFolderContacts).Folders("Another_Folder")
    
    ' 遍历所有已加载存储，查找John Doe的共享联系人文件夹
    For Each olStore In olNS.Stores
        On Error Resume Next
        Set olContactRoot = olStore.GetDefaultFolder(olFolderContacts)
        If Not olContactRoot Is Nothing Then
            Set olSourceFolder = olContactRoot.Folders("John Doe")
            ' 找到目标文件夹后执行复制
            If Not olSourceFolder Is Nothing Then
                For Each Item In olSourceFolder.Items
                    If Item.Class = olContact Then
                        Set copiedContact = Item.Copy
                        copiedContact.Move olTargetFolder
                    End If
                Next
                Exit For
            End If
        End If
        On Error GoTo 0
    Next
    
    ' 释放对象避免Outlook残留进程
    Set copiedContact = Nothing
    Set Item = Nothing
    Set olSourceFolder = Nothing
    Set olContactRoot = Nothing
    Set olStore = Nothing
    Set olTargetFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
    MsgBox "联系人复制完成", vbInformation
End Sub

注意事项 #

• 运行前确认Outlook侧已经正常加载了John Doe的共享联系人文件夹，文件夹名称和代码中填写的John Doe完全一致（注意区分大小写、前后空格）
• 代码仅复制类型为联系人的项目，会自动跳过文件夹内的分发列表、会议邀请等非联系人内容
• 若需要复制分发列表，可额外增加判断Item.Class = olDistributionList后执行相同的复制移动逻辑

内容的提问来源于stack exchange，提问作者tpthatsme