遍历Outlook联系人并校验字典时的误判问题排查

问题概述 #

编写的VBA代码功能为：遍历Outlook联系人生成包含邮箱、电话号码的Scripting.Dictionary；读取选中的订阅请求邮件，提取客户信息后与字典比对，判断订阅者是否已在联系人列表中。当前问题：代码有时会将确认不在联系人列表中的邮箱标记为“Already Existing”。

问题根源分析 #

1. 空键误加入字典：处理联系人电话/邮箱时，若原字段为全空格，或处理后变为空字符串，会被加入字典作为空键。当订阅邮件中对应字段为空时，会触发字典的空键匹配，误判为已存在。
2. 信息标准化不一致：联系人侧的邮箱会转小写并去除空格，但订阅邮件提取的邮箱未执行相同处理；电话格式化逻辑虽一致，但未确保处理后非空才加入字典。
3. 重复键解析异常：解析邮件HTML表格时，若存在重复键，dictTable.Add会抛出错误，导致后续字段提取失败，出现空值匹配空键的情况。

修复后的完整代码 #

Option Explicit

' 联系人文件夹路径
Public Const strContactFolder As String = "\youremail@xyz.com\Contacts"
' 重复联系人文件夹路径
Public Const strDupeFolder As String = "\TM Contacts\DuplicateContacts"
' 缺失信息联系人文件夹路径
Public Const strMissingFolder As String = "\TM Contacts\MissingInfo"

Public bolDedupe As Boolean

Sub AddSubs_Match_with_4Keys_4()
    Dim oContactFolder As Outlook.Folder
    Dim oDictionary As Object
    Dim i As Long
    Dim cObject As Object
    Dim oItem As Outlook.ContactItem
        
    Dim stPhone_Key As String, stMobile_Key As String, stOther_Key As String
    Dim stEmail_Key As String, stEmail2_Key As String

    Set oDictionary = CreateObject("Scripting.Dictionary")
    oDictionary.CompareMode = TextCompare ' 启用不区分大小写的键匹配
    Set oContactFolder = SetMyFolder(strContactFolder, False)

    If oContactFolder Is Nothing Then
        MsgBox "无法找到源联系人文件夹", vbCritical + vbOKOnly, "错误"
        Exit Sub
    End If

    For i = 1 To oContactFolder.Items.Count
        Set cObject = oContactFolder.Items.Item(i)

        If TypeOf cObject Is Outlook.ContactItem Then
            Set oItem = cObject

            ' 处理家庭电话：格式化后非空才加入字典
            If oItem.HomeTelephoneNumber <> "" Then
                stPhone_Key = Replace(Replace(Replace(Replace(oItem.HomeTelephoneNumber, "(", ""), ")", ""), "-", ""), " ", "")
                If stPhone_Key <> "" Then oDictionary(stPhone_Key) = True
            End If

            ' 处理移动电话：格式化后非空才加入字典
            If oItem.MobileTelephoneNumber <> "" Then
                stMobile_Key = Replace(Replace(Replace(Replace(oItem.MobileTelephoneNumber, "(", ""), ")", ""), "-", ""), " ", "")
                If stMobile_Key <> "" Then oDictionary(stMobile_Key) = True
            End If
            
            ' 处理其他电话：格式化后非空才加入字典
            If oItem.OtherTelephoneNumber <> "" Then
                stOther_Key = Replace(Replace(Replace(Replace(oItem.OtherTelephoneNumber, "(", ""), ")", ""), "-", ""), " ", "")
                If stOther_Key <> "" Then oDictionary(stOther_Key) = True
            End If

            ' 处理主邮箱：格式化后非空才加入字典
            If oItem.Email1Address <> "" Then
                stEmail_Key = Replace(LCase(oItem.Email1Address), " ", "")
                If stEmail_Key <> "" Then oDictionary(stEmail_Key) = True
            End If

            ' 处理备用邮箱：格式化后非空才加入字典
            If oItem.Email2Address <> "" Then
                stEmail2_Key = Replace(LCase(oItem.Email2Address), " ", "")
                If stEmail2_Key <> "" Then oDictionary(stEmail2_Key) = True
            End If
                            
        End If ' 仅处理ContactItem类型
    Next i

    If oDictionary.Count = 0 Then
        MsgBox "字典初始化异常！", vbOKOnly + vbCritical
        Exit Sub
    End If
    
    Dim oMail As Object
    Dim CSVLine As String
    Dim SelectedMails As Long
    
    For Each oMail In Application.ActiveExplorer.Selection
        If TypeName(oMail) = "MailItem" Then
            If InStr(1, oMail.Subject, "has subscribed to", vbTextCompare) > 0 Then
                Update_Contact_Info oMail, oDictionary, CSVLine
            End If
        End If
    Next

    SelectedMails = Application.ActiveExplorer.Selection.Count

    ' 生成结果CSV文件
    Dim CSVFilePath As String
    Dim CSVFile As Object
    
    CSVFilePath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\output.csv"
    
    ' 关闭已打开的CSV文件
    On Error Resume Next
    Set CSVFile = GetObject(CSVFilePath)
    On Error GoTo 0
    If Not CSVFile Is Nothing Then
        CSVFile.Close
        Set CSVFile = Nothing
    End If

    Set CSVFile = CreateObject("Scripting.FileSystemObject").CreateTextFile(CSVFilePath, True)
    With CSVFile
        .WriteLine "First Name,Last Name,Spouse,Email,Contact/Husband No,Wife No,Other No,Status"
        .WriteLine CSVLine
        .Close
    End With
    
    If SelectedMails < 11 Then
        CSVLine = Replace(CSVLine, ",", " ")
        MsgBox CSVLine, vbOKOnly + vbInformation, SelectedMails & " 封邮件已处理"
    End If
End Sub

Sub Update_Contact_Info(olMail As Outlook.MailItem, oDictionary As Object, CSVLine As String)
    Dim strBody As String
    Dim dKey As Variant
    
    Dim stFirst As String
    Dim stLast As String
    Dim stEmail As String
    Dim stSpouse As String
    Dim stAddress As String
    
    Dim stContact As String ' 丈夫电话
    Dim stWifeNum As String ' 妻子电话
    Dim stOther As String   ' 其他电话
    
    ' Outlook对象
    Dim oNS As Outlook.NameSpace
    Dim oContactFolder As Outlook.Folder
    Dim oContact As Outlook.ContactItem

    ' HTML解析对象
    Dim t0 As Object, tr As Object, td As Object, tKey As String, tVal As String, t1 As Object
    Dim iHtml As New HTMLDocument
    
    Dim dictTable As Scripting.Dictionary
    Set dictTable = New Scripting.Dictionary
    dictTable.CompareMode = TextCompare
    
    iHtml.Body.innerHTML = olMail.HTMLBody
    Set t0 = iHtml.getElementsByTagName("tr")
    
    For Each tr In t0
        Set t1 = tr.getElementsByTagName("td")
        tKey = ""
        tVal = ""
        For Each td In t1
            If tKey = "" Then
                tKey = LCase(Trim(Replace(td.innerText, ":", "", , , vbTextCompare)))
            Else
                tVal = Trim(td.innerText)
            End If
        Next
        
        ' 用赋值替代Add，自动覆盖重复键，避免报错
        If tKey <> "" Then dictTable(tKey) = tVal
    Next
    
    Dim bSingle As Boolean
    ' 判断邮件格式类型
    If dictTable.Exists("first name") And dictTable.Exists("last name") Then
        stFirst = dictTable("first name")
        stLast = dictTable("last name")
        bSingle = True
    ElseIf dictTable.Exists("husband first name") And dictTable.Exists("husband last name") Then
        stFirst = dictTable("husband first name")
        stLast = dictTable("husband last name")
        bSingle = False
    Else
        CSVLine = CSVLine & olMail.Subject & ",,,,,,,Unrecognized Email body" & vbCr
        Exit Sub
    End If
 
    ' 处理地址信息
    Dim sAddr2 As String
    stAddress = ""
    sAddr2 = ""
    For Each dKey In dictTable.Keys
        Select Case dKey
            Case "address"
                stAddress = dictTable(dKey)
            Case "city", "state", "zip"
                sAddr2 = sAddr2 & IIf(Len(sAddr2) > 0, ", ", "") & dictTable(dKey)
        End Select
    Next
    If Len(sAddr2) > 0 Then stAddress = stAddress & "," & vbCrLf & sAddr2
    
    ' 处理已婚用户信息
    If bSingle = False Then
        If dictTable.Exists("email") Then
            stEmail = Replace(LCase(dictTable("email")), " ", "") ' 邮箱标准化处理
        End If
        If dictTable.Exists("wife first name") Then stSpouse = dictTable("wife first name")
        If dictTable.Exists("wife last name") Then stSpouse = Trim(stSpouse & " " & dictTable("wife last name"))
        
        If dictTable.Exists("husband phone no.") Then
            stContact = Replace(Replace(Replace(Replace(dictTable("husband phone no."), "(", ""), ")", ""), "-", ""), " ", "")
        End If
        
        If dictTable.Exists("wife phone no.") Then
            stWifeNum = Replace(Replace(Replace(Replace(dictTable("wife phone no."), "(", ""), ")", ""), "-", ""), " ", "")
        End If
        
        If dictTable.Exists("other phone no.") Then
            stOther = Replace(Replace(Replace(Replace(dictTable("other phone no."), "(", ""), ")", ""), "-", ""), " ", "")
        End If
        
        GoTo MatchingWithDictionary
    End If

    ' 处理单身用户信息
    If dictTable.Exists("email") Then
        stEmail = Replace(LCase(dictTable("email")), " ", "") ' 邮箱标准化处理
    End If
    If dictTable.Exists("spouse name") Then stSpouse = dictTable("spouse name")
    
    If dictTable.Exists("contact phone") Then
        stContact = Replace(Replace(Replace(Replace(dictTable("contact phone"), "(", ""), ")", ""), "-", ""), " ", "")
    End If
    
    If dictTable.Exists("other phone") Then
        stOther = Replace(Replace(Replace(Replace(dictTable("other phone"), "(", ""), ")", ""), "-", ""), " ", "")
    End If

MatchingWithDictionary:
    ' 仅检查非空字段的存在性，避免空键匹配
    Dim isExisting As Boolean
    isExisting = False
    
    If stEmail <> "" And oDictionary.Exists(stEmail) Then isExisting = True
    If Not isExisting And stOther <> "" And oDictionary.Exists(stOther) Then isExisting = True
    If Not isExisting And stContact <> "" And oDictionary.Exists(stContact) Then isExisting = True
    
    If isExisting Then
        CSVLine = CSVLine & stFirst & "," & stLast & "," & stSpouse & "," & stEmail & "," & _
                 stContact & "," & stWifeNum & "," & stOther & ",Already Exist" & vbCr
        Exit Sub
    End If

    ' 添加新联系人
    Set oNS = Application.GetNamespace("MAPI")
    Set oContactFolder = SetMyFolder(strContactFolder, False)
    Set oContact = oContactFolder.Items.Add(olContactItem)
    
    With oContact
        .FirstName = stFirst
        .LastName = stLast
        .Email1Address = stEmail
        .Spouse = stSpouse
        .HomeAddress = stAddress
        .MobileTelephoneNumber = stContact  ' 丈夫电话
        .HomeTelephoneNumber = stWifeNum    ' 妻子电话
        .OtherTelephoneNumber = stOther     ' 其他电话
        .MessageClass = "IPM.Contact.Tiferes Miriam Contacts"
        .Save
    End With
    
    CSVLine = CSVLine & stFirst & "," & stLast & "," & stSpouse & "," & stEmail & "," & _
             stContact & "," & stWifeNum & "," & stOther & ",New Contact Added" & vbCr
End Sub

Function SetMyFolder(ByVal FolderPath As String, ByVal bolShared As Boolean) As Outlook.Folder
    Dim oFolder         As Outlook.Folder
    Dim FoldersArray    As Variant
    Dim i               As Integer
    Dim SubFolders      As Outlook.Folders
    Dim oApp As Outlook.Application
    Dim oNS As Outlook.NameSpace

    Set oApp = Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    
    FoldersArray = Split(FolderPath, "\")
    
    On Error GoTo SetMyFolder_Error
    If bolShared = True Then
        Set oFolder = oNS.Folders(FoldersArray(0))
        If Not oFolder Is Nothing Then
            For i = 1 To UBound(FoldersArray, 1)
                Set oFolder = oFolder.Folders(FoldersArray(i))
                If oFolder Is Nothing Then Exit For
            Next
        End If
    Else
        Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
        If Not oFolder Is Nothing Then
            For i = 1 To UBound(FoldersArray, 1)
                Set SubFolders = oFolder.Folders
                Set oFolder = SubFolders.Item(FoldersArray(i))
                If oFolder Is Nothing Then Exit For
            Next
        End If
    End If
    
    Set SetMyFolder = oFolder
    Exit Function
        
SetMyFolder_Error:
    Set SetMyFolder = Nothing
    Exit Function
End Function

关键修改说明 #

1. 字典空键拦截：处理联系人的电话/邮箱字段时，增加If stXXX_Key <> "" Then判断，确保只有非空的标准化值才加入字典。
2. 信息标准化统一：订阅邮件提取的邮箱执行与联系人侧一致的Replace(LCase(...), " ", "")处理，确保匹配逻辑一致。
3. 重复键处理：解析邮件表格时，用dictTable(tKey) = tVal替代dictTable.Add，自动覆盖重复键，避免报错中断流程。
4. 匹配逻辑优化：将原有的多字段OR判断改为分步检查，仅在字段非空时才验证字典存在性，彻底避免空键误匹配。
5. 字典匹配模式：为字典添加oDictionary.CompareMode = TextCompare，启用不区分大小写的键匹配，避免大小写差异导致的匹配失败。

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