Outlook VBA中如何访问用户自定义字段以筛选复制联系人？

你的核心问题是错误地判断了文件夹的自定义属性，而非单个联系人的"Team"字段值。原代码中MyP.item(9).Name = "Accounting"是在检查文件夹的第9个自定义属性名称，完全偏离了筛选联系人字段的逻辑。

以下是两种可靠的解决方案：

方法1：使用ContactItem的UserProperties集合 #

直接针对每个联系人项，通过UserProperties.Find获取"Team"字段的值：

Sub CopyContactsByTeam()
    Dim olNameSpace As NameSpace
    Dim sourceFolder As Folder
    Dim destFolder As Folder
    Dim contactItem As ContactItem
    Dim copiedItem As ContactItem
    Dim teamProp As UserProperty
    
    ' 初始化文件夹对象
    Set olNameSpace = Application.GetNamespace("MAPI")
    Set sourceFolder = olNameSpace.GetDefaultFolder(olFolderContacts)
    Set destFolder = sourceFolder.Folders("Contacts.1.01") ' 目标文件夹路径
    
    ' 遍历所有联系人项
    For Each contactItem In sourceFolder.Items
        ' 仅处理联系人类型项目
        If contactItem.Class = olContact Then
            ' 查找当前联系人的"Team"自定义字段
            Set teamProp = contactItem.UserProperties.Find("Team", True)
            ' 检查字段是否存在且值为"Accounting"
            If Not teamProp Is Nothing And teamProp.Value = "Accounting" Then
                Set copiedItem = contactItem.Copy
                copiedItem.Move destFolder
            End If
        End If
    Next contactItem
    
    ' 释放对象
    Set teamProp = Nothing
    Set copiedItem = Nothing
    Set contactItem = Nothing
    Set destFolder = Nothing
    Set sourceFolder = Nothing
    Set olNameSpace = Nothing
    
    MsgBox "筛选复制完成！"
End Sub

方法2：使用PropertyAccessor（推荐，避免名称冲突） #

如果自定义字段名称有特殊字符或存在重名风险，用PropertyAccessor通过MAPI属性名访问更可靠：

Sub CopyContactsByTeam_PropertyAccessor()
    Dim olNameSpace As NameSpace
    Dim sourceFolder As Folder
    Dim destFolder As Folder
    Dim contactItem As ContactItem
    Dim copiedItem As ContactItem
    Dim teamPropDef As UserDefinedProperty
    Dim propAccessor As PropertyAccessor
    Dim teamValue As Variant
    
    ' 初始化文件夹
    Set olNameSpace = Application.GetNamespace("MAPI")
    Set sourceFolder = olNameSpace.GetDefaultFolder(olFolderContacts)
    Set destFolder = sourceFolder.Folders("Contacts.1.01")
    
    ' 获取文件夹中"Team"自定义字段的MAPI属性定义
    Set teamPropDef = sourceFolder.UserDefinedProperties.Find("Team")
    If teamPropDef Is Nothing Then
        MsgBox "未找到名为'Team'的自定义字段！"
        Exit Sub
    End If
    
    ' 遍历联系人
    For Each contactItem In sourceFolder.Items
        If contactItem.Class = olContact Then
            Set propAccessor = contactItem.PropertyAccessor
            ' 通过MAPI属性名获取字段值
            teamValue = propAccessor.GetProperty(teamPropDef.PropertyName)
            If teamValue = "Accounting" Then
                Set copiedItem = contactItem.Copy
                copiedItem.Move destFolder
            End If
        End If
    Next contactItem
    
    ' 释放对象
    Set propAccessor = Nothing
    Set teamPropDef = Nothing
    Set copiedItem = Nothing
    Set contactItem = Nothing
    Set destFolder = Nothing
    Set sourceFolder = Nothing
    Set olNameSpace = Nothing
    
    MsgBox "筛选复制完成！"
End Sub

关键注意事项 #

• 确保"Team"是联系人项的自定义字段，而非仅文件夹的自定义属性（需在联系人编辑界面确认字段存在）
• 遍历Items集合时，可添加sourceFolder.Items.Sort "[FullName]"排序，或使用Restrict方法提前筛选（提升大文件夹的处理效率）：

  ' 示例：用Restrict提前筛选Team=Accounting的联系人
  Dim filteredItems As Items
  Set filteredItems = sourceFolder.Items.Restrict("[Team] = 'Accounting'")
  

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