基于任务正文字符数删除重复Outlook任务的VBA宏修改需求

我目前在用一个Outlook VBA宏，它会在启动时自动执行收件箱规则并删除重复项，但最近遇到个麻烦——编辑新任务后正文内容变了，宏就识别不出同名的重复任务了。我想把它改成依据任务正文的字符数来判定重复，比如用类似判断正文长度是否超过32字符的逻辑来调整重复识别规则。

下面是我原来在用的宏代码：

Private Sub Application_Startup()
    RunAllInboxRules
    RemoveDuplicateItems
End Sub

Sub RunAllInboxRules()
    Dim st As Outlook.Store
    Dim myRules As Outlook.Rules
    Dim rl As Outlook.Rule
    Dim count As Integer
    Dim ruleList As String
    'On Error Resume Next
    ' get default store (where rules live)
    Set st = Application.Session.DefaultStore
    ' get rules
    Set myRules = st.GetRules
    ' iterate all the rules
    For Each rl In myRules
        ' determine if it's an Inbox rule
        If rl.RuleType = olRuleReceive And rl.IsLocalRule = True Then
            ' if so, run it
            rl.Execute ShowProgress:=True
            count = count + 1
            ruleList = ruleList & vbCrLf & rl.Name
        End If
    Next
    ' tell the user what you did
    ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
    MsgBox ruleList, vbInformation, "Macro: RunAllInboxRules"
    Set rl = Nothing
    Set st = Nothing
    Set myRules = Nothing
End Sub

Sub RemoveDuplicateItems()
    Dim objFolder As Folder
    Dim objDictionary As Object
    Dim i As Long
    Dim objItem As Object
    Dim strKey As String
    Set objDictionary = CreateObject("scripting.dictionary")
    'Select a source folder
    Set objFolder = Outlook.Application.Session.PickFolder
    If Not (objFolder Is Nothing) Then
        For i = objFolder.Items.count To 1 Step -1
            Set objItem = objFolder.Items.Item(i)
            Select Case objFolder.DefaultItemType
                'Check email subject, body and sent time
                Case olMailItem
                    strKey = objItem.subject & "," & objItem.Body & "," & objItem.SentOn
                'Check appointment subject, start time, duration, location and body
                Case olAppointmentItem
                    strKey = objItem.subject & "," & objItem.Start & "," & objItem.Duration & "," & objItem.Location & "," & objItem.Body
                'Check contact full name and email address
                Case olContactItem
                    strKey = objItem.FullName & "," & objItem.Email1Address & "," & objItem.Email2Address & "," & objItem.Email3Address
                'Check task subject, start date, due date and body
                Case olTaskItem
                    strKey = objItem.subject & "," & objItem.StartDate & "," & objItem.DueDate & "," & objItem.Body
            End Select
            strKey = Replace(strKey, ", ", Chr(32))
            'Remove the duplicate items
            If objDictionary.Exists(strKey) = True Then
                objItem.Delete
            Else
                objDictionary.Add strKey, True
            End If
        Next i
    End If
End Sub

修改后的宏代码 #

针对任务的重复判定逻辑，我调整了RemoveDuplicateItems里的任务处理分支，加入了正文字符数的判断：

Private Sub Application_Startup()
    RunAllInboxRules
    RemoveDuplicateItems
End Sub

Sub RunAllInboxRules()
    Dim st As Outlook.Store
    Dim myRules As Outlook.Rules
    Dim rl As Outlook.Rule
    Dim count As Integer
    Dim ruleList As String
    'On Error Resume Next
    ' get default store (where rules live)
    Set st = Application.Session.DefaultStore
    ' get rules
    Set myRules = st.GetRules
    ' iterate all the rules
    For Each rl In myRules
        ' determine if it's an Inbox rule
        If rl.RuleType = olRuleReceive And rl.IsLocalRule = True Then
            ' if so, run it
            rl.Execute ShowProgress:=True
            count = count + 1
            ruleList = ruleList & vbCrLf & rl.Name
        End If
    Next
    ' tell the user what you did
    ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
    MsgBox ruleList, vbInformation, "Macro: RunAllInboxRules"
    Set rl = Nothing
    Set st = Nothing
    Set myRules = Nothing
End Sub

Sub RemoveDuplicateItems()
    Dim objFolder As Folder
    Dim objDictionary As Object
    Dim i As Long
    Dim objItem As Object
    Dim strKey As String
    Dim taskBodyLength As Integer ' 存储任务正文字符数
    Set objDictionary = CreateObject("scripting.dictionary")
    'Select a source folder
    Set objFolder = Outlook.Application.Session.PickFolder
    If Not (objFolder Is Nothing) Then
        For i = objFolder.Items.count To 1 Step -1
            Set objItem = objFolder.Items.Item(i)
            Select Case objFolder.DefaultItemType
                'Check email subject, body and sent time
                Case olMailItem
                    strKey = objItem.subject & "," & objItem.Body & "," & objItem.SentOn
                'Check appointment subject, start time, duration, location and body
                Case olAppointmentItem
                    strKey = objItem.subject & "," & objItem.Start & "," & objItem.Duration & "," & objItem.Location & "," & objItem.Body
                'Check contact full name and email address
                Case olContactItem
                    strKey = objItem.FullName & "," & objItem.Email1Address & "," & objItem.Email2Address & "," & objItem.Email3Address
                ' 修改任务重复判定逻辑：依据正文字符数
                Case olTaskItem
                    taskBodyLength = Len(objItem.Body)
                    ' 当正文字符数超过32时，用字符数代替具体正文内容判定重复
                    If taskBodyLength > 32 Then
                        strKey = objItem.subject & "," & objItem.StartDate & "," & objItem.DueDate & "," & taskBodyLength
                    Else
                        ' 正文较短时仍用完整内容判定（可根据需求调整）
                        strKey = objItem.subject & "," & objItem.StartDate & "," & objItem.DueDate & "," & objItem.Body
                    End If
            End Select
            strKey = Replace(strKey, ", ", Chr(32))
            'Remove the duplicate items
            If objDictionary.Exists(strKey) = True Then
                objItem.Delete
            Else
                objDictionary.Add strKey, True
            End If
        Next i
    End If
End Sub

关键修改点 #

• 新增taskBodyLength变量，通过Len(objItem.Body)获取任务正文的字符数；
• 在任务处理分支中加入条件判断：如果正文字符数超过32，就用任务标题+开始日期+截止日期+正文字符数作为重复识别的标识，这样即使正文有小改动，只要这几个字段一致就会被判定为重复；
• 如果你想统一用正文字符数判定，不管长度多少，直接去掉If判断，把strKey设置为objItem.subject & "," & objItem.StartDate & "," & objItem.DueDate & "," & taskBodyLength即可。

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