如何提取Outlook中邮件自定义后续标记对应的文本内容

解决方案 #

Outlook 中所有邮件的自定义跟进标记文本都存储在FlagRequest属性中，只要筛选该属性非空的邮件即可匹配到所有符合要求的内容，基于你原来的递归遍历文件夹的逻辑修改后的完整可运行代码如下：

Sub ExtractFlaggedEmailsWithCustomText()
    Dim objMainFolder As Outlook.Folder
    Dim resultArr As Variant
    Dim arrIndex As Long
    Dim fs As Object
    Dim ts As Object
    Dim savePath As String
    Dim i As Long
    Dim subject As String
    Dim sender As String
    
    ' 初始化结果数组，4列：主题、发件人、接收时间、自定义标记文本
    ReDim resultArr(1 To 4, 1 To 10000)
    arrIndex = 1
    
    ' 选择要扫描的文件夹
    Set objMainFolder = Outlook.Application.Session.PickFolder
    If objMainFolder Is Nothing Then
       MsgBox "请选择有效的文件夹！", vbExclamation + vbOKOnly, "选择文件夹提示"
       Exit Sub
    End If
    
    ' 递归扫描文件夹及子文件夹
    Call ScanFolderForFlaggedMails(objMainFolder, resultArr, arrIndex)
    
    ' 无匹配邮件提示
    If arrIndex = 1 Then
        MsgBox "所选文件夹内未找到带自定义标记的邮件", vbInformation, "扫描结果"
        Exit Sub
    End If
    
    ' 导出结果到桌面CSV文件
    savePath = Environ("USERPROFILE") & "\Desktop\带自定义标记的邮件列表.csv"
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set ts = fs.CreateTextFile(savePath, True, True)
    ' 写入表头
    ts.WriteLine "邮件主题,发件人,接收时间,自定义标记文本"
    ' 写入内容
    For i = 1 To arrIndex - 1
        ' 处理内容里的逗号避免CSV错位
        subject = Replace(resultArr(1, i), ",", "，")
        sender = Replace(resultArr(2, i), ",", "，")
        ts.WriteLine """" & subject & """,""" & sender & """," & resultArr(3, i) & ",""" & resultArr(4, i) & """"
    Next
    ts.Close
    
    MsgBox "扫描完成，共找到 " & arrIndex - 1 & " 封带自定义标记的邮件，结果已保存到桌面：" & vbCrLf & savePath, vbInformation, "执行完成"
End Sub

Sub ScanFolderForFlaggedMails(ByVal objCurrentFolder As Outlook.Folder, ByRef resultArr As Variant, ByRef arrIndex As Long)
    Dim objItem As Object
    Dim objMail As Outlook.MailItem
    Dim objSubfolder As Outlook.Folder
    
    ' 遍历当前文件夹所有条目
    For Each objItem In objCurrentFolder.Items
        ' 仅处理邮件类型的条目
        If TypeName(objItem) = "MailItem" Then
            Set objMail = objItem
            ' 筛选自定义后续标记不为空的邮件
            If Not IsNull(objMail.FlagRequest) And Trim(objMail.FlagRequest) <> "" Then
                ' 数组容量不足时自动扩容
                If arrIndex > UBound(resultArr, 2) Then
                    ReDim Preserve resultArr(1 To 4, 1 To UBound(resultArr, 2) + 10000)
                End If
                ' 写入邮件信息
                resultArr(1, arrIndex) = objMail.Subject
                resultArr(2, arrIndex) = objMail.SenderName
                resultArr(3, arrIndex) = Format(objMail.ReceivedTime, "yyyy-mm-dd hh:mm:ss")
                resultArr(4, arrIndex) = objMail.FlagRequest
                arrIndex = arrIndex + 1
            End If
        End If
    Next
    
    ' 递归处理所有子文件夹
    If objCurrentFolder.Folders.Count > 0 Then
       For Each objSubfolder In objCurrentFolder.Folders
           Call ScanFolderForFlaggedMails(objSubfolder, resultArr, arrIndex)
       Next
    End If
End Sub

使用步骤 #

• 打开Outlook客户端，按下Alt + F11组合键调出VBA编辑器
• 在左侧工程资源管理器中右键点击ThisOutlookSession，依次选择「插入」-「模块」
• 将上面的代码粘贴到新建的模块窗口中
• 按下F5键运行代码，在弹出的窗口中选择需要扫描的邮件文件夹
• 扫描完成后结果会自动保存到桌面的带自定义标记的邮件列表.csv文件，可直接用Excel打开编辑、导出使用

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