如何自动将 Outlook 中的电子邮件转发到原始电子邮件正文中的电子邮件地址？

Question

我每天早上都会收到大量电子邮件，其中包含我需要转发给相关方的信息。这些是时间敏感信息，因此需要自动化此过程。

一些附加信息：

• 原始电子邮件的发件人始终相同
• 转发电子邮件的收件人总是不同的。相关电子邮件是 在原始电子邮件的正文中说明
• 我还需要编辑电子邮件的主题以包含更多文本 原始电子邮件的主题标题。

例如：

原始电子邮件

<from: xxx@123.com>
Subject: Stackoverflow Sample Test

Main body: 
Please forward this e-mail to: yyy@123.com , zzz@123.com
Please add this into subject title: DONE

转发的电子邮件

<To: yyy@123.com ; zzz@123.com>
Subject: FW: Stackoverflow Sample Test DONE

提前感谢您的帮助！

Answer 1

下面的代码需要参考。本机 VBA 有限；它对 MailItems 或 Worksheets 或 Documents 或 Tables 或 Office 产品使用的任何其他对象一无所知。

在 Outlook VBA 编辑器中，单击“工具”，然后单击“参考”。将显示一长串库，顶部有几个勾选。这些勾选的库将包括“Microsoft Library nn.0 Object Library”。 “nn”的值取决于您使用的 Outlook 版本。正是这个库告诉 VBA 文件夹和 MailItems 以及所有其他 Outlook 对象。

下面的代码需要引用“Microsoft Scripting Runtime”和“Microsoft ActiveX Data Objects n.n Library”。在我的系统上，“n.n”是“6.1”。如果未勾选这些库，请向下滚动列表，直到找到它们并勾选它们。下次单击引用时，这些库将位于列表顶部。

您说您需要处理的电子邮件都具有相同的格式。您说您需要的数据以表格形式保存。你的意思是一个 Html 表还是一个带有非换行符来对齐列的文本表？表格可能看起来相同，但格式却截然不同。下面的代码是我需要调查一两封电子邮件的确切格式时使用的例程。我上面引用的答案包括我想调查大量电子邮件时使用的例程。

要使用下面的例程，插入一个没有 Outlook 的新模块并将下面的代码复制到它。选择一两封您希望处理的电子邮件，然后运行InvestigateEmails()。它将在您的桌面上创建一个名为“InvestigateEmails.txt”的文件，其中包含所选电子邮件的一些属性。特别是，它将包含文本和 Html 正文。控制字符 CR、LF 和 TB 将被字符串替换，否则这些主体将与 VBA 宏一样。在不知道 VBA 宏看起来如何的情况下，您无法从可用正文或正文中提取目标电子邮件地址。

我说这是我用来调查一两封电子邮件的例行程序。这不是全部真相。我的例程输出了更多属性，但除了我认为对你有用的那些之外，我已经删除了所有属性。如果我错过了您需要的东西，我可以添加更多属性。

Option Explicit
Public Sub InvestigateEmails()

  ' Outputs properties of selected emails to a file.

  ' ???????  No record of when originally coded
  ' 22Oct16  Output to desktop file rather than Immediate Window.

  ' Technique for locating desktop from answer by Kyle:
  ' http://stackoverflow.com/a/17551579/973283
  ' Needs reference to "Microsoft Scripting Runtime"

  Dim Exp As Explorer
  Dim FileBody As String
  Dim Fso As FileSystemObject
  Dim ItemCrnt As MailItem
  Dim Path As String

  Path = CreateObject("WScript.Shell").specialfolders("Desktop")

  Set Exp = Outlook.Application.ActiveExplorer

  If Exp.Selection.Count = 0 Then
    Call MsgBox("Pleaase select one or more emails then try again", vbOKOnly)
    Exit Sub
  Else
    FileBody = ""
    For Each ItemCrnt In Exp.Selection
      With ItemCrnt
        FileBody = FileBody & "From (Sender): " & .Sender & vbLf
        FileBody = FileBody & "From (Sender name): " & .SenderName & vbLf
        FileBody = FileBody & "From (Sender email address): " & _
                              .SenderEmailAddress & vbLf
        FileBody = FileBody & "Subject: " & CStr(.Subject) & vbLf
        Call OutLongText(FileBody, "Text: ", Replace(Replace(Replace(.Body, vbLf, _
                         "{lf}" & vbLf), vbCr, "{cr}"), vbTab, "{tb}"))
        Call OutLongText(FileBody, "Html: ", Replace(Replace(Replace(.HtmlBody, vbLf, _
                         "{lf}" & vbLf), vbCr, "{cr}"), vbTab, "{tb}"))
        FileBody = FileBody & "--------------------------" & vbLf
      End With
    Next
  End If

  Call PutTextFileUtf8NoBOM(Path & "\InvestigateEmails.txt", FileBody)

End Sub
Public Sub OutLongText(ByRef FileBody As String, ByVal Head As String, _
                       ByVal Text As String)

  Dim PosEnd As Long
  Dim LenOut As Long
  Dim PosStart As Long

  If Text <> "" Then
    PosStart = 1
    Do While PosStart <= Len(Text)
      PosEnd = InStr(PosStart, Text, vbLf)
      If PosEnd = 0 Or PosEnd > PosStart + 100 Then
        ' No LF in remainder of text or next 100 characters
        PosEnd = PosStart + 99
        LenOut = 100
      Else
        ' Output upto LF.  Restart output after LF
        LenOut = PosEnd - PosStart
        PosEnd = PosEnd
      End If
      If PosStart = 1 Then
        FileBody = FileBody & Head
      Else
        FileBody = FileBody & Space(Len(Head))
      End If
      FileBody = FileBody & Mid$(Text, PosStart, LenOut) & vbLf
      PosStart = PosEnd + 1
    Loop
  End If

End Sub
Public Sub PutTextFileUtf8NoBOM(ByVal PathFileName As String, ByVal FileBody As String)

  ' Outputs FileBody as a text file named PathFileName using
  ' UTF-8 encoding without leading BOM

  ' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
  ' Addition to original code says version 2.5. Tested with version 6.1.

  '  1Nov16  Copied from http://stackoverflow.com/a/4461250/973283
  '          but replaced literals with parameters.
  ' 15Aug17  Discovered routine was adding an LF to the end of the file.
  '          Added code to discard that LF.
  ' 11Oct17  Posted to StackOverflow
  '  9Aug18  Comment from rellampec suggested removal of adWriteLine from
  '          WriteTest statement would avoid adding LF.
  ' 30Sep18  Amended routine to remove adWriteLine from WriteTest statement
  '          and code to remove LF from file. Successfully tested new version.

  ' References: http://stackoverflow.com/a/4461250/973283
  '             https://www.w3schools.com/asp/ado_ref_stream.asp

  Dim BinaryStream As Object
  Dim UTFStream As Object

  Set UTFStream = CreateObject("adodb.stream")

  UTFStream.Type = adTypeText
  UTFStream.Mode = adModeReadWrite
  UTFStream.Charset = "UTF-8"
  UTFStream.Open
  UTFStream.WriteText FileBody

  UTFStream.Position = 3 'skip BOM

  Set BinaryStream = CreateObject("adodb.stream")
  BinaryStream.Type = adTypeBinary
  BinaryStream.Mode = adModeReadWrite
  BinaryStream.Open

  UTFStream.CopyTo BinaryStream

  UTFStream.Flush
  UTFStream.Close
  Set UTFStream = Nothing

  BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
  BinaryStream.Flush
  BinaryStream.Close
  Set BinaryStream = Nothing

End Sub