用于自动执行搜索和转发过程的Outlook宏

Question

这可能吗？

是否有一种方法可以使用宏，该宏将自动在收件箱中搜索电子邮件的主题行的一部分，然后将搜索结果转发到另一封电子邮件？

示例：COMPLETE电子邮件进入收件箱，电子邮件的主题行是“ This is the subject COMPLETE”，我希望Outlook在我的收件箱中搜索“主题”，主题行中带有“主题”的所有电子邮件都将转发到另一封电子邮件。

编辑：为澄清起见，宏应始终搜索COMPLETE左侧的项目（字母和数字的组合，始终为15个字符）。

[此外，一旦完整的电子邮件进入收件箱，就无需触发（可以手动触发），但是需要将每封完整的电子邮件视为一个单独的“工作”，以重复搜索并为每封电子邮件转发完成该主题。

谢谢！

Answer 1

我将尽力让您入门，但只有您可以调试任何代码，因为只有您拥有要转发的电子邮件。我已经创建了一些电子邮件，这些电子邮件与我对您的电子邮件的理解相符，但是我无法确定自己是否正确。

我不知道您知道多少VBA。通常，一旦知道存在一条语句，就可以很容易地在网上搜索解释。因此，我将集中精力解释我的代码在做什么。

对于宏的第一阶段，您需要收集以下信息：

abcdefghijklmno  Email1  Email2  Email3 . . .
bcdefghijklmnop  Email4  Email5 . . .

其中“ abcdefghijklmno”和“ bcdefghijklmnop”是“工作”的代码，而Email1至Email5是主题包含代码的电子邮件。

对于宏，文件夹（例如收件箱）是一个集合。识别特定电子邮件的方法有多种，但我认为最方便的方法是根据其在集合中的位置或索引。添加到文件夹的第一封电子邮件的索引为1，第二封电子邮件的索引为2，依此类推。如果您了解数组，这似乎很熟悉。区别在于，您可以从集合中删除现有项目或在集合中间添加新项目。假设我有一个包含项A，B，C，E和F的集合，它们的索引为1到5。我现在在项C和E之间添加项D。项A到C仍然是项1到3。但是D是现在，第4项，E变成了第5项，F变成了第6项。当删除一个项目，而集合中的第一个项目的索引编号减小时，情况则相反。这可能很奇怪，但是我相信稍后它变得很重要时，它将变得更加清晰。

所以我们需要创建的是：

abcdefghijklmno  25  34  70 . . .
bcdefghijklmnop  29  123 . . .

您可以在Option Explicit之后查找，第一个语句为Type tFamily。 VBA带有多种数据类型，例如：Long，Double，String和Boolean。有时，仅靠这些本身还不够，我们需要将它们组合成VBA称为用户类型和大多数其他语言的调用结构。您可能听说过课程。类比用户类型有所提高，我们不需要它们的额外功能或额外的复杂性。

所以我写了：

Type tFamily
  Code As String
  Members As Collection
End Type

在这里，我将一个字符串和一个集合组合成一个更大的类型，我将其命名为tFamily。 “ t”是我的标准，因为我经常很难想到类型和变量的不同名称。此类型与我上面描述的数据匹配。我已经将所有具有相同代码的电子邮件称为“家庭”。在一个家庭中，我有一个字符串来保存代码，并有一个集合来保存所有索引。

在我的代码下面，我定义了一系列的数组：

  Dim Families() As tFamily

这是我将保存有关电子邮件系列的所有信息的地方。

下一个重要声明是：

  Set FldrInbox = Session.Folders("xxx").Folders("Inbox")

您需要使用共享邮箱的名称替换“ xxx”。

第一段代码，标题为[[标识'COMPLETE'电子邮件，并在InxsItemComplete中记录其索引] >>扫描Inbox中的所有电子邮件，并记录每封电子邮件的索引，其主题以“ COMPLETE”结尾。对于上面的示例数据，最后，InxsItemComplete将包含123和70。下一个语句是ReDim Families(1 To InxsItemComplete.Count)。 InxsItemComplete.Count是完整家族的数量。该语句调整数组Families的大小，以便可以容纳此数目的族。可以在集合中包含集合，但数组中的集合更简单。

下一个块从每个“ COMPLETE”中提取代码，并将其和“ COMPLETE”电子邮件的索引存储在Families中。该代码假定电子邮件主题为：

xxxxxxxxxx abcdefghijklmno spaces COMPLETE

代码将PosCodeEnd设置为指向“ COMPLETE”之前。备份直到找到非空格，然后提取前15个字符。该代码然后存储在Families(InxF).Code中。电子邮件的索引已添加到Families(InxF).Members。

下一个块再次扫描收件箱中的所有电子邮件。这次是寻找主题包含代码但不以“ COMPLETE”结尾的电子邮件。它将这些电子邮件的索引添加到Families(InxF).Members。添加这些索引，以便它们按升序排列。我将解释为什么当我添加此宏的下一阶段来转发电子邮件时，此顺序很重要。

到此阶段1结束。已经收集了转发电子邮件所需的所有数据。其余代码块将数据输出到立即窗口，以便可以检查它。使用我的测试电子邮件，输出为：

abcdefghijklmno
  122 06/10/2019 13:28:38 Introductory text aaa abcdefghijklmno Progress
  124 06/10/2019 13:27:35 Introductory text ccccc  abcdefghijklmno Progress
  126 06/10/2019 13:26:05 Introductory text ccccc  abcdefghijklmno  Progress
  127 06/10/2019 13:24:54 Introductory text aaa abcdefghijklmno  COMPLETE
zyxwvutsrqponml
  121 06/10/2019 13:29:10 Introductory text bbbbbb  zyxwvutsrqponml COMPLETE
  123 06/10/2019 13:28:00 Introductory text bbbbbb  zyxwvutsrqponml   Progress
  125 06/10/2019 13:26:38 Introductory text aaa zyxwvutsrqponml  Progress

此数据的重要部分是：

abcdefghijklmno
  122
  124
  126
  127
zyxwvutsrqponml
  121
  123
  125

这是代码，索引是记录的数据。接收到的时间和主题可以帮助您识别参考的电子邮件。

您需要运行此宏并检查以下输出：

已识别出所有主题为“ COMPLETE”的电子邮件。
• 已正确提取代码。
• 已找到并记录了每封包含代码的电子邮件。
• 每个代码的索引按升序排列。
• 如有需要，请返回问题。但是，请记住，我看不到您的电子邮件，因此在调试方面我能提供多少帮助是有限的。确认诊断输出正确后，我将添加阶段2的代码。

Option Explicit
Type tFamily
  Code As String
  Members As Collection
End Type
Sub FindAndForwardCompleteConversations()

  Dim Families() As tFamily
  Dim FldrInbox As Folder
  Dim InxItemCrnt As Long
  Dim InxF As Long          ' Index into Families and InxsItemComplete
  Dim InxM As Long          ' Index into members of current family
  Dim InxsItemComplete As New Collection
  Dim Placed As Boolean
  Dim PosCodeEnd As Long
  Dim Subject As String

  Set FldrInbox = Session.Folders("xxx").Folders("Inbox")

  ' Identify the 'COMPLETE' emails and record their indices
  For InxItemCrnt = FldrInbox.Items.Count To 1 Step -1
    With FldrInbox.Items.Item(InxItemCrnt)
      If .Class = olMail Then
        If Right$(.Subject, 8) = "COMPLETE" Then
          InxsItemComplete.Add InxItemCrnt
        End If
      End If
    End With
  Next

  ReDim Families(1 To InxsItemComplete.Count)

  ' Extract code from each "COMPLETE" emails and start families with 'COMPLETE' email
  For InxF = 1 To InxsItemComplete.Count
    Subject = FldrInbox.Items.Item(InxsItemComplete(InxF)).Subject
    PosCodeEnd = Len(Subject) - 8 ' Position to space before COMPLETE
    ' Position to first non-space character before COMPLETE
    Do While Mid$(Subject, PosCodeEnd, 1) = " "
      PosCodeEnd = PosCodeEnd - 1
    Loop
    Families(InxF).Code = Mid$(Subject, PosCodeEnd - 14, 15)
    Set Families(InxF).Members = New Collection
    Families(InxF).Members.Add InxsItemComplete(InxF)
  Next

  Set InxsItemComplete = Nothing   ' Release memory of collection which is no longer needed

  ' Identify emails containing the same code as the 'COMPLETE' emails
  ' and add to the appropriate Family
  For InxItemCrnt = FldrInbox.Items.Count To 1 Step -1
    With FldrInbox.Items.Item(InxItemCrnt)
      If .Class = olMail Then
        Placed = False
        For InxF = 1 To UBound(Families)
          If Right$(.Subject, 8) <> "COMPLETE" And _
             InStr(1, .Subject, Families(InxF).Code) <> 0 Then
            ' Add InxItemCrnt to collection of members for this family
            ' so that indices are in ascending sequence
            For InxM = 1 To Families(InxF).Members.Count
              If InxItemCrnt < Families(InxF).Members(InxM) Then
                Families(InxF).Members.Add Item:=InxItemCrnt, Before:=InxM
                Placed = True
                Exit For
              End If
            Next
            If Not Placed Then
              Families(InxF).Members.Add Item:=InxItemCrnt
              Placed = True
            End If
          End If
          If Placed Then
            ' Email added to current family so not need to check other families
            Exit For
          End If
        Next
      End If
    End With
  Next

  ' Output collected information
  For InxF = 1 To UBound(Families)
    Debug.Print Families(InxF).Code
    For InxM = 1 To Families(InxF).Members.Count
      InxItemCrnt = Families(InxF).Members(InxM)
      With FldrInbox.Items.Item(InxItemCrnt)
        Debug.Print "  " & InxItemCrnt & " " & .ReceivedTime & " " & .Subject
      End With
    Next
  Next

End Sub