基于邮件正文内容重命名并转格式保存Outlook邮件附件

以下是满足需求的完整VBA代码，包含订单编号提取、附件格式筛选、DOC转PDF及重命名保存功能：

Sub SAVE_ATT(item As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim orderNumber As String
    Dim tempFilePath As String
    Dim wordApp As Object ' Word应用对象，用于DOC转PDF
    Dim doc As Object ' Word文档对象
    
    saveFolder = "C:\TEMP\"
    ' 确保保存目录存在，不存在则创建
    If Dir(saveFolder, vbDirectory) = "" Then
        MkDir saveFolder
    End If
    
    ' 检查邮件正文是否包含目标标识"order-33"
    If InStr(1, item.Body, "order-33", vbTextCompare) = 0 Then
        Exit Sub ' 无标识则直接退出
    End If
    
    For Each objAtt In item.Attachments
        ' 只处理DOC和PDF格式的附件
        Select Case LCase(Right(objAtt.FileName, 4))
            Case ".doc", ".pdf"
                tempFilePath = saveFolder & objAtt.FileName
                ' 先临时保存附件
                objAtt.SaveAsFile tempFilePath
                
                ' 根据附件类型提取订单编号
                If LCase(Right(objAtt.FileName, 4)) = ".pdf" Then
                    orderNumber = ExtractOrderNumberFromPDF(tempFilePath)
                Else
                    orderNumber = ExtractOrderNumberFromDOC(tempFilePath)
                End If
                
                ' 提取到订单编号才继续处理
                If orderNumber <> "" Then
                    ' 处理DOC转PDF
                    If LCase(Right(objAtt.FileName, 4)) = ".doc" Then
                        On Error Resume Next
                        Set wordApp = CreateObject("Word.Application")
                        wordApp.Visible = False ' 后台运行Word
                        Set doc = wordApp.Documents.Open(tempFilePath)
                        ' 保存为PDF（17对应Word的PDF格式常量）
                        doc.SaveAs2 saveFolder & orderNumber & ".pdf", FileFormat:=17
                        doc.Close
                        wordApp.Quit
                        ' 删除临时DOC文件
                        Kill tempFilePath
                        On Error GoTo 0
                    Else
                        ' PDF直接重命名
                        Name tempFilePath As saveFolder & orderNumber & ".pdf"
                    End If
                End If
        End Select
        Set objAtt = Nothing
    Next objAtt
    
    ' 释放对象
    Set wordApp = Nothing
    Set doc = Nothing
End Sub

' 从PDF文件中提取订单编号的函数（依赖Adobe Acrobat API，需安装Acrobat而非Reader）
Function ExtractOrderNumberFromPDF(pdfPath As String) As String
    Dim acroApp As Object
    Dim acroAVDoc As Object
    Dim acroPDDoc As Object
    Dim pageText As String
    Dim startPos As Integer, endPos As Integer
    
    On Error Resume Next
    Set acroApp = CreateObject("AcroExch.App")
    Set acroAVDoc = CreateObject("AcroExch.AVDoc")
    
    If acroAVDoc.Open(pdfPath, "") Then
        Set acroPDDoc = acroAVDoc.GetPDDoc
        ' 提取第一页文本（假设订单号在第一页，可根据实际调整）
        pageText = acroPDDoc.GetPageNth(0).GetText
        ' 查找"order number"对应的编号，假设格式为"order number: 12345"
        startPos = InStr(1, pageText, "order number:", vbTextCompare)
        If startPos > 0 Then
            startPos = startPos + Len("order number:")
            ' 跳过空格
            Do While Mid(pageText, startPos, 1) = " "
                startPos = startPos + 1
            Loop
            ' 找到编号结束位置（假设到非数字/非连字符为止）
            endPos = startPos
            Do While IsNumeric(Mid(pageText, endPos, 1)) Or Mid(pageText, endPos, 1) = "-"
                endPos = endPos + 1
            Loop
            ExtractOrderNumberFromPDF = Trim(Mid(pageText, startPos, endPos - startPos))
        End If
        acroAVDoc.Close False
    End If
    
    acroApp.Exit
    Set acroPDDoc = Nothing
    Set acroAVDoc = Nothing
    Set acroApp = Nothing
    On Error GoTo 0
End Function

' 从DOC文件中提取订单编号的函数
Function ExtractOrderNumberFromDOC(docPath As String) As String
    Dim wordApp As Object
    Dim doc As Object
    Dim range As Object
    Dim startPos As Integer, endPos As Integer
    
    On Error Resume Next
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False
    Set doc = wordApp.Documents.Open(docPath)
    Set range = doc.Content
    
    ' 查找"order number"对应的编号，假设格式为"order number: 12345"
    startPos = InStr(1, range.Text, "order number:", vbTextCompare)
    If startPos > 0 Then
        startPos = startPos + Len("order number:")
        ' 跳过空格
        Do While Mid(range.Text, startPos, 1) = " "
            startPos = startPos + 1
        Loop
        ' 找到编号结束位置
        endPos = startPos
        Do While IsNumeric(Mid(range.Text, endPos, 1)) Or Mid(range.Text, endPos, 1) = "-"
            endPos = endPos + 1
        Loop
        ExtractOrderNumberFromDOC = Trim(Mid(range.Text, startPos, endPos - startPos))
    End If
    
    doc.Close False
    wordApp.Quit
    Set range = Nothing
    Set doc = Nothing
    Set wordApp = Nothing
    On Error GoTo 0
End Function

关键功能说明 #

• 目录自动创建：检测C:\TEMP目录，不存在则自动生成
• 邮件过滤：仅处理正文包含order-33标识的邮件
• 附件类型筛选：只对.doc和.pdf格式附件执行后续操作
• 订单编号提取：
  • PDF提取依赖Adobe Acrobat API（需安装完整版Acrobat，免费Reader无法实现）
  • DOC提取通过Word对象模型后台完成，无需打开可视化窗口
  • 默认适配order number: XXXXX格式，可根据实际订单号格式调整提取逻辑
• 格式转换与重命名：
  • DOC文件自动转换为PDF格式，以订单号命名，临时DOC文件自动删除
  • PDF文件直接重命名为订单号

注意事项 #

1. 运行前需确保已安装Microsoft Word（处理DOC文件）和Adobe Acrobat（处理PDF文件提取）
2. 若订单号格式与假设不同，需修改两个提取函数中的文本查找逻辑
3. 需在Outlook中启用宏，并调整宏安全设置允许运行此代码

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