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

我将尝试让您开始，但只有您可以调试任何代码，因为只有您拥有要转发的电子邮件。我创建了一些与我对您的电子邮件的理解相匹配的电子邮件，但我不能确定我是否完全正确。

我不知道你对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

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

在我的代码下方，我定义了一系列家庭：

  Dim Families() As tFamily

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

下一个重要声明是：

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

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

第一个代码块，标题为Identify the 'COMPLETE' emails and record their index in InxsItemComplete扫描收件箱中的所有电子邮件，并记录每封电子邮件的索引，主题以“COMPLETE”结尾。对于上面的示例数据，最后InxsItemComplete将包含 123 和 70。

下一条语句是ReDim Families(1 To InxsItemComplete.Count)。 InxsItemComplete.Count是完整家庭的数量。此语句大小数组Families，因此它可以容纳这个数量的家庭。集合中可以有集合，但数组中的集合更简单。

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

xxxxxxxxxx abcdefghijklmno spaces COMPLETE

代码设置PosCodeEnd为指向“完成”之前。它会进行备份，直到找到一个非空格，然后提取前 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

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

问题描述

解决方案

推荐阅读