向Outlook邮件中添加信息

编程语言 2026-07-07

我有一个工具，可以将邮件发送给Excel表中的名单，给它们分配投递延迟（确保每分钟发送一封），并以Word文档作为邮件正文：

Private Sub CommandButton1_Click()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olAccount As Outlook.Account
Dim RecipientEmail As String
Dim RecipientName As String
Dim CompleteFilePath As String
Dim oWord As Object
Dim oWordDocument As Object
Dim oOutlookEditor As Object
Dim String_Greeting As String
Dim String_Closing As String

' This chooses the newsletter you want to send
  With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Show
    .Filters.Add "Word Files", "*.docx", 1
    CompleteFilePath = .SelectedItems.Item(1)
  End With
  MsgBox ("The newsletter you have chosen is: " & vbCrLf & CompleteFilePath)

' This is entering the preferred Subject
  SubjectLine = InputBox("Enter the subject line of the email." & vbCrLf & vbCrLf & "Please start it with '[redacted]: '", "Email Subject")

' This determines how many email addresses we'll be sending to, based on what's in the Addresses sheet:
  LastRow = ThisWorkbook.Sheets("Addresses").Range("B" & Rows.Count).End(xlUp).Row

' Build the email body
  Set oWord = CreateObject("Word.Application")
  oWord.Visible = True
  Set oWordDocument = oWord.Documents.Open(CompleteFilePath, , False)
  oWordDocument.Content.Copy

For MailCounter = 2 To LastRow

  Set olApp = New Outlook.Application
  Set olMail = olApp.CreateItem(olMailItem)

  With olMail
    .Display

     RecipientName = ThisWorkbook.Sheets("Addresses").Range("A" & MailCounter)
     If Trim(RecipientName) = "" Then RecipientName = "Hellbender" ' Because I hate blanks
     String_Greeting = "Greetings, " & RecipientName

     RecipientEmail = ThisWorkbook.Sheets("Addresses").Range("B" & MailCounter)
     String_Closing = "You are subscribed as " & RecipientEmail & "."

    .To = RecipientEmail
    .Subject = SubjectLine & " - test " & MailCounter - 1 & " minute send"
    .Body = Test
    Set oOutlookEditor = .GetInspector.WordEditor
    oOutlookEditor.Content.Paste

    '.Body = "Greetings " & RecipientName & ", this is test #" & MailCounter - 1 & "."
    ' .DeferredDeliveryTime = DateAdd("n", MailCounter, Now) ' This starts with the first email delayed 2 minutes, and then all other emails delayed by incrementing it a minute.
    ' .Send
    .DeferredDeliveryTime = DateAdd("n", 20, Now) ' twenty minutes ought to be enough to troubleshoot.
    .Send

  End With ' olMail

Next MailCounter ' End email loop.

End Sub

但有一个操作我还没搞清楚怎么做。我想让每封邮件以 String_Greeting 开头，在邮件末尾再加上 String_Closing。

当我随意使用邮件合并（也就是“手动”进行时），那些只是字段。如果有办法在我的Word文档中注入一个字段，然后在代码中用这些字符串填充该字段，那就太妙了。

或者，如果有办法在正文前插入并在末尾追加文本，也能实现。比如：

.Body = String_Greeting & .Body & String_Closing

这也能行。但在粘贴的正文是一个对象时，怎么实现呢？

解决方案

呃，答案消失了。很怪。好吧，以防将来的人需要：

答案的关键在于理解.Body是一个区域，并使用InsertBefore和 InsertAfter。

如上面的代码所实现，相关的代码段变成了：

Set oOutlookEditor = .GetInspector.WordEditor
oOutlookEditor.Content.Paste
oOutlookEditor.Content.InsertBefore String_Greeting & vbCrLf & vbCrLf
oOutlookEditor.Content.InsertAfter vbCrLf & vbCrLf & String_Closing

它工作得很棒，感谢前面发帖的那位。

Outlook