如何自動將 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 有關文件夾和郵件項目以及所有其他 Outlook 對象的信息。

下面的代碼需要引用“Microsoft Scripting Runtime”和“Microsoft ActiveX Data Objects nn Library”。 在我的系統上，“nn”是“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