Outlook公共文件夹附件含关键词邮件的识别与实时告警需求

一、一次性全文件夹（含子文件夹）PDF关键词搜索 #

方案1：基于Adobe Acrobat Pro的VBA实现 #

适用于已安装Adobe Acrobat Pro的场景，直接通过API读取PDF文本：

1. 打开Outlook，按Alt+F11进入VBA编辑器
2. 点击工具→引用，勾选Adobe Acrobat xx.x Type Library（替换为你的Acrobat版本号）
3. 插入模块，粘贴以下代码：

Sub SearchPDFKeywordsInAllFolders()
    Dim rootFolder As Folder
    Dim targetKeyword As String
    targetKeyword = "你的关键词" ' 替换为目标关键词
    
    ' 设置公共文件夹根路径，替换为实际路径
    Set rootFolder = Application.Session.Folders("公共文件夹名称").Folders("目标父文件夹")
    
    Call TraverseFolders(rootFolder, targetKeyword)
    MsgBox "搜索完成，结果可按Ctrl+G在即时窗口查看"
End Sub

Sub TraverseFolders(currentFolder As Folder, keyword As String)
    Dim mailItem As MailItem
    Dim attachment As attachment
    Dim acroDoc As Acrobat.CAcroPDDoc
    Dim pageNum As Integer
    Dim pageText As String
    
    ' 遍历当前文件夹邮件
    For Each mailItem In currentFolder.Items
        If mailItem.Class = olMail Then
            For Each attachment In mailItem.Attachments
                If LCase(Right(attachment.FileName, 4)) = ".pdf" Then
                    Set acroDoc = New Acrobat.CAcroPDDoc
                    ' 临时保存附件
                    attachment.SaveAsFile Environ("TEMP") & "\" & attachment.FileName
                    If acroDoc.Open(Environ("TEMP") & "\" & attachment.FileName) Then
                        pageText = ""
                        ' 读取所有页面文本
                        For pageNum = 0 To acroDoc.GetNumPages() - 1
                            pageText = pageText & acroDoc.GetPageNthWord(pageNum, 0, acroDoc.GetPageNumWords(pageNum))
                        Next pageNum
                        ' 匹配关键词
                        If InStr(LCase(pageText), LCase(keyword)) > 0 Then
                            Debug.Print "匹配邮件：" & mailItem.Subject & " | 所在文件夹：" & currentFolder.Name
                            mailItem.Categories = "关键词匹配" ' 标记邮件
                            mailItem.Save
                        End If
                        acroDoc.Close
                    End If
                    ' 清理临时文件
                    Kill Environ("TEMP") & "\" & attachment.FileName
                    Set acroDoc = Nothing
                End If
            Next attachment
        End If
    Next mailItem
    
    ' 递归遍历子文件夹
    Dim subFolder As Folder
    For Each subFolder In currentFolder.Folders
        Call TraverseFolders(subFolder, keyword)
    Next subFolder
End Sub

4. 替换代码中的文件夹名称和关键词，运行SearchPDFKeywordsInAllFolders宏

方案2：基于pdftotext的无Acrobat实现 #

无需Acrobat，需先下载pdftotext工具并放到本地路径：

Sub SearchPDFKeywordsWithPdftotext()
    Dim rootFolder As Folder
    Dim targetKeyword As String
    Dim pdftotextPath As String
    targetKeyword = "你的关键词"
    pdftotextPath = "C:\tools\pdftotext.exe" ' 替换为你的工具路径
    
    Set rootFolder = Application.Session.Folders("公共文件夹名称").Folders("目标父文件夹")
    Call TraverseFoldersWithPdftotext(rootFolder, targetKeyword, pdftotextPath)
    MsgBox "搜索完成"
End Sub

Sub TraverseFoldersWithPdftotext(currentFolder As Folder, keyword As String, pdftPath As String)
    Dim mailItem As MailItem
    Dim attachment As attachment
    Dim tempPDF As String, tempTxt As String
    Dim txtContent As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    For Each mailItem In currentFolder.Items
        If mailItem.Class = olMail Then
            For Each attachment In mailItem.Attachments
                If LCase(Right(attachment.FileName, 4)) = ".pdf" Then
                    tempPDF = Environ("TEMP") & "\" & attachment.FileName
                    tempTxt = Replace(tempPDF, ".pdf", ".txt")
                    attachment.SaveAsFile tempPDF
                    
                    ' 调用pdftotext提取文本
                    Shell pdftPath & " """ & tempPDF & """ """ & tempTxt & """", vbHide
                    Application.Wait Now + TimeValue("00:00:02") ' 等待处理完成，可根据文件大小调整
                    
                    If fso.FileExists(tempTxt) Then
                        txtContent = fso.OpenTextFile(tempTxt, 1).ReadAll
                        If InStr(LCase(txtContent), LCase(keyword)) > 0 Then
                            Debug.Print "匹配邮件：" & mailItem.Subject & " | 所在文件夹：" & currentFolder.Name
                            mailItem.Categories = "关键词匹配"
                            mailItem.Save
                        End If
                        Kill tempTxt
                    End If
                    Kill tempPDF
                End If
            Next attachment
        End If
    Next mailItem
    
    ' 递归遍历子文件夹
    Dim subFolder As Folder
    For Each subFolder In currentFolder.Folders
        Call TraverseFoldersWithPdftotext(subFolder, keyword, pdftPath)
    Next subFolder
    Set fso = Nothing
End Sub

二、新邮件到达时的关键词告警 #

通过Outlook事件监控所有子文件夹的新邮件，触发关键词匹配告警：

1. 在VBA编辑器中，双击Microsoft Outlook Objects下的ThisOutlookSession
2. 插入类模块，命名为FolderMonitor，粘贴以下代码：

Public WithEvents FolderItems As Items
Private targetKeyword As String

Private Sub Class_Initialize()
    targetKeyword = "你的关键词" ' 替换为目标关键词
End Sub

Private Sub FolderItems_ItemAdd(ByVal Item As Object)
    Dim mailItem As MailItem
    Dim attachment As attachment
    Dim acroDoc As Acrobat.CAcroPDDoc
    Dim pageText As String
    Dim pageNum As Integer
    
    If Item.Class = olMail Then
        Set mailItem = Item
        For Each attachment In mailItem.Attachments
            If LCase(Right(attachment.FileName, 4)) = ".pdf" Then
                Set acroDoc = New Acrobat.CAcroPDDoc
                attachment.SaveAsFile Environ("TEMP") & "\" & attachment.FileName
                If acroDoc.Open(Environ("TEMP") & "\" & attachment.FileName) Then
                    pageText = ""
                    For pageNum = 0 To acroDoc.GetNumPages() - 1
                        pageText = pageText & acroDoc.GetPageNthWord(pageNum, 0, acroDoc.GetPageNumWords(pageNum))
                    Next pageNum
                    If InStr(LCase(pageText), LCase(targetKeyword)) > 0 Then
                        ' 弹出告警窗口
                        MsgBox "新邮件匹配关键词：" & mailItem.Subject & vbCrLf & "发件人：" & mailItem.SenderName, vbExclamation, "邮件告警"
                        ' 可选：自动发送通知邮件给自己
                        ' Dim alertMail As MailItem
                        ' Set alertMail = Application.CreateItem(olMailItem)
                        ' alertMail.Subject = "公共文件夹告警：" & mailItem.Subject
                        ' alertMail.To = "你的邮箱地址"
                        ' alertMail.Send
                    End If
                    acroDoc.Close
                End If
                Kill Environ("TEMP") & "\" & attachment.FileName
                Set acroDoc = Nothing
            End If
        Next attachment
    End If
End Sub

3. 返回ThisOutlookSession，粘贴以下代码：

Private monitors As Collection

Private Sub Application_Startup()
    Set monitors = New Collection
    Dim rootFolder As Folder
    ' 设置公共文件夹根路径
    Set rootFolder = Application.Session.Folders("公共文件夹名称").Folders("目标父文件夹")
    Call AddFolderMonitor(rootFolder)
End Sub

Private Sub AddFolderMonitor(folder As Folder)
    Dim monitor As New FolderMonitor
    Set monitor.FolderItems = folder.Items
    monitors.Add monitor
    ' 递归添加子文件夹监控
    Dim subFolder As Folder
    For Each subFolder In folder.Folders
        Call AddFolderMonitor(subFolder)
    Next subFolder
End Sub

4. 重启Outlook，监控自动生效

常见问题排查 #

• 宏被禁用：在Outlook选项→信任中心→信任中心设置→宏设置中，选择"启用所有宏"（或签名宏）
• Acrobat引用失败：确认安装Adobe Acrobat Pro，重新添加引用
• 权限不足：确保对目标公共文件夹拥有读写权限
• 大PDF处理超时：延长Application.Wait的等待时间

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