如何用Outlook VBA提取邮件主题工单ID并批量删除相关邮件

需求说明 #

• 共享工单系统会生成两类邮件：
  • 员工提交请求后，发送主题为Review Ticket - Ticket: TI-0000145176的待审核工单邮件
  • 若工单被其他成员处理，会收到主题为Automatic Approval - Ticket: TI-0000145176的自动审批邮件
• 需要实现：收到自动审批邮件时，找到对应待审核邮件并批量删除两者，避免重复处理已完成工单（无法修改工单系统的邮件配置）

实现情况 #

最初在提取主题中的统一格式工单ID时遇到阻碍，参考相关方案后已完成核心功能，代码保留了日志输出，方便手动验证删除的工单是否正确。最终可用的VBA代码如下：

Sub Delete_approved_expense_reports()

Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim filteredItems2 As Outlook.Items
Dim reportNumbers As String
Dim reportNumbers2 As String
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim strFilter2 As String


Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%Automatic Approval - Ticket: TI-0000%'"
strFilter2 = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%Review Ticket - Ticket: TI-%'"

Set filteredItems = objFolder.Items.Restrict(strFilter)
Set filteredItems2 = objFolder.Items.Restrict(strFilter2)


If filteredItems.Count = 0 Then
    Debug.Print "No emails found"
    Found = False
Else
    Found = True
    For Each itm In filteredItems
     '处理主题末尾可能存在的冗余内容
     reportNumbers = Left(Mid(itm.Subject, InStr(1, itm.Subject, "TI-0000", 1)), 13)
     For Each jtm In filteredItems2
      reportNumbers2 = Mid(jtm.Subject, Len(jtm.Subject) - 12)
      If reportNumbers2 = reportNumbers Then
       jtm.Delete
      '记录被删除的已处理工单ID
       Debug.Print reportNumbers2
      End If
     itm.Delete
     Next
      
    
    Next
End If


If Not Found Then
    'NoResults.Show
Else
   Debug.Print "Found " & filteredItems.Count & " items."

End If

'myOlApp.Quit
Set myOlApp = Nothing

End Sub

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