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库nn.0对象库”。 “ nn”的值将取决于您使用的Outlook版本。正是这个库告诉VBA有关Folders和MailItems以及所有其他Outlook对象的信息。

下面的代码需要引用“ Microsoft脚本运行时”和“ Microsoft ActiveX数据对象n.n库”。在我的系统上，“ 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

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

1 个答案: