Vba 根据主题行的一部分转发电子邮件

有没有办法在收件箱中搜索电子邮件主题行的一部分，然后将搜索结果转发到其他电子邮件地址

示例：
完整的电子邮件进入收件箱，电子邮件的主题行是“这是完整的主题”。我希望任何主题行中带有“主题”的电子邮件都转发到其他电子邮件地址

编辑：为了澄清，宏应该在主题行中搜索字母和数字的组合，长度始终为15个字符，位于“完成”的左侧

---

此外，当完整的电子邮件进入收件箱时，不需要触发宏（可以手动触发）。它需要将每封完整的电子邮件视为一个单独的“作业”，以重复搜索并转发主题中包含完整内容的每封电子邮件。

我将尝试让您开始，但只有您可以调试任何代码，因为只有您有要转发的电子邮件。我已经创建了一些电子邮件，符合我对你的电子邮件的理解，但我不能确定我得到的是完全正确的

我不知道你知道多少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具有多种数据类型，例如：长、双精度、字符串和布尔值。有时，仅仅依靠这些还不够，我们需要将它们组合到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”替换为共享邮箱的名称

第一段代码，标题为识别“完整”电子邮件并在InxsItemComplete中记录其索引扫描收件箱中的所有电子邮件，并记录每封邮件的索引，主题以“COMPLETE”结尾。对于上面的示例数据，最后，

inxsitemplete

将包含123和70

下一条语句是

ReDim系列（1到inxsitemplete.Count）

inxsitemplete.Count

是完整族的数量。此语句调整数组

族的大小

，以便它可以容纳此数量的族。集合中可以有集合，但数组中的集合更简单

下一个块从每个“完整”中提取代码，并将其和“完整”电子邮件的索引存储在

系列中。代码假定电子邮件主题类似于：

xxxxxxxxxx abcdefghijklmno spaces COMPLETE

代码将
PosCodeEnd
设置为“完成”之前的点。它将进行备份，直到找到非空格，然后提取前面的15个字符。然后，此代码存储在
系列（InxF）中。code
。电子邮件的索引将添加到
系列（InxF）.Members

下一个区块再次扫描收件箱中的所有电子邮件。这一次是寻找主题包含代码但不以“完成”结尾的电子邮件。它将这些电子邮件的索引添加到
系列（InxF）.Members
。这些索引是按升序添加的。我将在添加转发电子邮件的宏的下一阶段时解释为什么此序列很重要

这是第一阶段的结束。已收集转发电子邮件所需的所有数据。剩下的代码块将数据输出到即时窗口，以便进行检查。对于我的测试电子邮件，输出为：

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

即代码和索引是记录的数据。收到的时间和主题将帮助您识别引用的电子邮件

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


每封主题以“完成”结尾的电子邮件都已识别
代码已正确提取
所有包含代码的电子邮件都已发送
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