从Word文档生成电子邮件（Outlook）

Question

我正在尝试创建一个代码，用于打开特定文件夹中的每个 Word 文档，并从文件中提取电子邮件的 .subject、.to 和 .body。

例如，下面有一个文件格式的示例。但电子邮件的数量不是固定的..主题总是以相同的单词开头，正文也是如此。

---

[电子邮件受保护] [电子邮件受保护] [电子邮件受保护] [电子邮件受保护] [电子邮件受保护]

主题示例 - VBA 代码 - MM/DD/YYYY

亲爱的同事们，

等等等等

我尝试了多种不同的代码，但没有一个能够 100% 正常工作。我每天都要向客户发送结算建议。

下面的代码无法正常工作。

Sub CreateEmailFromWord()

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

    ' Define email item
    Dim emailItem As Object
    Set emailItem = outlookApp.CreateItem(0) ' 0 represents an email

    ' Open the Word document
    Dim wdApp As Object
    Set wdApp = CreateObject("Word.Application")
    
    ' Replace "C:\Path\To\Your\Document.docx" with the path to your Word document
    Dim wdDoc As Object
    Set wdDoc = wdApp.Documents.Open("C:\Path\To\Your\Document.docx")

    ' Find the recipient in the document body (assuming recipients are in email format)
    Dim recipient As String
    recipient = ExtractInformation(wdDoc.Content, "[\w\.-]+@[\w\.-]+")

    ' Find the subject in the document body
    Dim subject As String
    subject = ExtractInformation(wdDoc.Content, "Derivative Operation Settlement - (.+?)\r")

    ' Find the email body
    Dim emailBody As String
    emailBody = ExtractInformation(wdDoc.Content, "Dear Sirs,[\s\S]+")

    ' Fill in the email information
    emailItem.To = recipient
    emailItem.Subject = subject
    emailItem.Body = emailBody

    ' Display the email before sending (optional)
    emailItem.Display

    ' Send the email
    ' emailItem.Send

    ' Close the Word document
    wdDoc.Close False
    Set wdDoc = Nothing

    ' Quit the Word application
    wdApp.Quit
    Set wdApp = Nothing

    ' Clean up Outlook objects
    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

Answer 1

• recipient

  仅从文档中提取第一个电子邮件地址。
• 更改正则表达式模式以捕获所有电子邮件地址并用逗号替换空格

    recipient = Replace(ExtractInformation(wdDoc.Content, "([\w\.-]+@[\w\.-]+\s*)+"), " ", ",")

Answer 2

如果您的模式可能与文本的多个部分匹配（例如在查找邮件时），您可以执行如下示例所示的操作：更改

ExtractInformation

函数以返回

Collection

匹配项，然后循环全部（对于电子邮件）或仅使用第一项（主题等）

Sub tester()
    Dim m
    For Each m In ExtractInformation("Hello [email protected] [email protected] world", _
                                     "[\w\.-]+@[\w\.-]+")
        Debug.Print m
        'emailItem.Recipients.Add m
    Next m
End Sub


'Return a collection of all matches to pattern `pattern` in `text`
Function ExtractInformation(text As String, pattern As String) As Collection
    Dim matches As Object, match As Object
    
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .pattern = pattern
        Set matches = .Execute(text)
    End With
    
    Set ExtractInformation = New Collection
    For Each match In matches
        ExtractInformation.Add match.Value
    Next match
End Function