基于Word文档批量生成Outlook邮件的VBA代码优化需求

需要实现遍历指定文件夹下所有Word文档，从中提取邮件收件人（.To）、主题（.Subject）和正文（.Body）信息，用于生成Outlook邮件。文档格式说明：

• 收件人邮箱数量不固定，以空格分隔
• 主题以固定词汇开头
• 正文以固定词汇开头

格式示例：

xxx@xxxx.xx xxx@xxxx.xx xxx@xxxx.xx xxx@xxxx.xx xxx@xxxx.xx
Subject Example - VBA Code - MM/DD/YYYY
Dear Collegues,
Etc, Etc, etc

现有初始代码存在两大问题：无法保留Word文档格式，且仅能提取第一个邮箱地址。目前已对代码进行更新，但仍需完善。以下为初始代码及更新后的代码：

初始代码 #

Sub CreateEmailFromWord()

    ' 定义Outlook应用对象
    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")

    ' 定义邮件项
    Dim emailItem As Object
    Set emailItem = outlookApp.CreateItem(0) ' 0代表邮件类型

    ' 打开Word应用
    Dim wdApp As Object
    Set wdApp = CreateObject("Word.Application")
    
    ' 将"C:\Path\To\Your\Document.docx"替换为你的Word文档路径
    Dim wdDoc As Object
    Set wdDoc = wdApp.Documents.Open("C:\Path\To\Your\Document.docx")

    ' 在文档正文中查找收件人（假设为邮箱格式）
    Dim recipient As String
    recipient = ExtractInformation(wdDoc.Content, "[\w\.-]+@[\w\.-]+")

    ' 在文档正文中查找主题
    Dim subject As String
    subject = ExtractInformation(wdDoc.Content, "Derivative Operation Settlement - (.+?)\r")

    ' 查找邮件正文
    Dim emailBody As String
    emailBody = ExtractInformation(wdDoc.Content, "Dear Sirs,[\s\S]+")

    ' 填充邮件信息
    emailItem.To = recipient
    emailItem.Subject = subject
    emailItem.Body = emailBody

    ' 发送前显示邮件（可选）
    emailItem.Display

    ' 发送邮件
    ' emailItem.Send

    ' 关闭Word文档
    wdDoc.Close False
    Set wdDoc = Nothing

    ' 退出Word应用
    wdApp.Quit
    Set wdApp = Nothing

    ' 清理Outlook对象
    Set emailItem = Nothing
    Set outlookApp = Nothing

End Sub

Function ExtractInformation(text As String, pattern As String) As String
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = pattern
    End With

    Dim match As Object
    Set match = regex.Execute(text)

    If match.Count > 0 Then
        ExtractInformation = match(0)
    Else
        ExtractInformation = ""
    End If
End Function

更新后的代码 #

Sub CreateEmailsFromWordDocuments()

    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")

    ' 定义文件夹路径
    Dim folderPath As String
    folderPath = "FolderPath"

    Dim fileName As String
    fileName = Dir(folderPath & "*.docx")

    Do While fileName <> ""
        Dim emailItem As Object
        Set emailItem = outlookApp.CreateItem(0)

        Dim wdApp As Object
        Set wdApp = CreateObject("Word.Application")

        Dim wdDoc As Object
        Set wdDoc = wdApp.Documents.Open(folderPath & fileName)
        Dim recipient As String
        recipient = ExtractInformation(wdDoc.Content, "([\w\.-]+@[\w\.-]+(;|$))+")
        
        Dim subject As String
        subject = ExtractInformation(wdDoc.Content.text, "Liquidação de Operação de Derivativo*(.+?)\r")
        
        Dim emailBody As String
        emailBody = ExtractInformation(wdDoc.Content.text, "Prezados Senhores,[\s\S]+")

        With emailItem
            .To = recipient
            .Subject = subject
            .CC = "Liquidação"
            .Body = emailBody
            .Display
        End With

        wdDoc.Close False
        Set wdDoc = Nothing
        
        wdApp.Quit
        Set wdApp = Nothing
        
        fileName = Dir
    Loop

    ' 清理Outlook应用引用
    Set outlookApp = Nothing
End Sub


Function ExtractInformation(text As String, pattern As String) As String

    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = pattern
    End With

    Dim match As Object
    Set match = regex.Execute(text)

    If match.Count > 0 Then
        ExtractInformation = match(0)
    Else
        ExtractInformation = ""
    End If
End Function

内容的提问来源于stack exchange，提问作者Giulliano Accarini De Luccia