Как объединить и пересылать электронные письма в одно письмо в Outlook с помощью сценария?

Question

У меня есть учетная запись, в которой я получаю около 10 ежедневных обновлений / отчетов с разных устройств. Теперь вместо пересылки отдельных писем в DL я хочу объединить эти 10 писем в одно письмо и переслать его на другое письмо. Есть ли сценарий / правило, которое может автоматизировать процесс? Я думаю, что это будет работать так:

1. Between 12AM-12:30AM I would receive all the emails in the inbox
2. At 1AM, the script would run to combine all the emails in the inbox and send it to another email account
3. At 1:05AM, move all inbox emails to another folder so that inbox is empty

Answer 1

Я предлагаю вам скопировать приведенный ниже код в новый модуль Outlook.

В верхней части кода находятся две константы, дающие имя папки, содержащей электронные письма, которые необходимо объединить, и имя папки на который следует переместить электронные письма после слияния. Вы должны изменить эту константу, чтобы она соответствовала именам ваших папок.

Первый макрос - Demo1(). Этот макрос доказывает, что вы правильно установили константы, задавая ссылки на две папки и затем отображая их имена. Любая проблема с вашими константами, и код будет остановлен.

Второй макрос - Demo2(). Этот макрос отображает время получения и тему каждого электронного письма в исходной папке, за которым следуют имена всех вложений. Это позволяет вам проверить, соответствуют ли электронные письма и вложения к ним sh. Примечания:

1. Этот макрос отображает все вложения. Подписи, логотипы, изображения и т. Д. - все это приложения. Настоящий макрос пересылает только вложения PDF, но я хотел, чтобы вы знали о любых других вложениях.

2. Доступ к элементам в исходной папке осуществляется в обратном порядке (For InxI = FldrSrc.Items.Count To 1 Step -1). Доступ к элементам почты осуществляется по их положению в папке. Если вы переместите почтовый элемент 10, скажем, в другую папку, элемент 11 станет элементом 10, элемент 12 станет элементом 11 и так далее. Это означало бы, что пункт 11 никогда не рассматривался. Обращаясь к элементам в обратном порядке, мне все равно, что элемент 11 стал элементом 10, потому что я уже отмечал элемент 11.

Последний макрос - MergeEmailsAndForward(). Я считаю, что это все, что вы хотите. Примечания:

1. Ближе к концу макроса находится оператор .Recipients.Add "TonyDallimore23@gmail.com". Для тестирования я отправил объединенное электронное письмо на одну из моих дополнительных учетных записей. Вам понадобится .Recipients.Add "xxxx@xxxx.com" для каждого человека или группы, которые получат электронное письмо.

2. Я установил в теме сегодняшнюю дату. Возможно, вам придется отрегулировать это.

Надеюсь, все это имеет смысл.

Option Explicit

  ' Names of folders. The first part identifies the store. Other parts
  ' identify folders to any depth of nesting.
  ' Replace with the names of your source and destination folders
  Const FldrSrcName As String = "Outlook Data File\Inbox"
  Const FldrProcName As String = "Outlook Data File\Inbox\Processed"
Sub Demo1()

  Dim FldrName As String
  Dim FldrNamePart() As String
  Dim FldrSrc As Outlook.Folder
  Dim FldrProc As Outlook.Folder
  Dim FldrTemp As Outlook.Folder
  Dim InxFN As Long

  ' Create reference to source folder
  FldrNamePart = Split(FldrSrcName, "\")
  Set FldrSrc = Session.Folders(FldrNamePart(0))
  For InxFN = 1 To UBound(FldrNamePart)
    Set FldrSrc = FldrSrc.Folders(FldrNamePart(InxFN))
  Next
  ' The above is equivalent to:
  '      Set FldrInbox = Session.Folders(Outlook Data File).Folders("Inbox")

  ' Create reference to processed folder
  FldrNamePart = Split(FldrProcName, "\")
  Set FldrProc = Session.Folders(FldrNamePart(0))
  For InxFN = 1 To UBound(FldrNamePart)
    Set FldrProc = FldrProc.Folders(FldrNamePart(InxFN))
  Next
  ' The above is equivalent to:
  '      Set FldrInbox = Session.Folders(Outlook Data File).Folders("Inbox").folders("Processed")

  ' Display name of source folder
  FldrName = FldrSrc.Name
  Set FldrTemp = FldrSrc.Parent
  Do While True
    FldrName = FldrTemp.Name & "\" & FldrName
    If TypeName(FldrTemp.Parent) = "NameSpace" Then
      Exit Do
    End If
    Set FldrTemp = FldrTemp.Parent
  Loop
  Debug.Print FldrName
  ' The above is equivalent to:
  '     Debug.Print FldrInbox.Parent.Name & "\" & FldrInbox.Name

  ' Display name of processed folder
  FldrName = FldrProc.Name
  Set FldrTemp = FldrProc.Parent
  Do While True
    FldrName = FldrTemp.Name & "\" & FldrName
    If TypeName(FldrTemp.Parent) = "NameSpace" Then
      Exit Do
    End If
    Set FldrTemp = FldrTemp.Parent
  Loop
  Debug.Print FldrName
  ' The above is equivalent to:
  '     Debug.Print FldrProc.Parent.Parent.Name & "\" & FldrProc.Parent.Name & "\" & FldrProc.Name

End Sub
Sub Demo2()

  Dim AttachCrnt As Attachment
  Dim FldrNamePart() As String
  Dim FldrSrc As Outlook.Folder
  Dim FldrProc As Outlook.Folder
  Dim InxA As Long
  Dim InxFN As Long
  Dim InxI As Long
  Dim ItemCrnt As MailItem

  FldrNamePart = Split(FldrSrcName, "\")
  Set FldrSrc = Session.Folders(FldrNamePart(0))
  For InxFN = 1 To UBound(FldrNamePart)
    Set FldrSrc = FldrSrc.Folders(FldrNamePart(InxFN))
  Next

  For InxI = FldrSrc.Items.Count To 1 Step -1
    Set ItemCrnt = FldrSrc.Items(InxI)
    With ItemCrnt
      Debug.Print .ReceivedTime & " " & .Subject
      For InxA = 1 To ItemCrnt.Attachments.Count
        Set AttachCrnt = ItemCrnt.Attachments(InxA)
        With AttachCrnt
          Debug.Print "  " & InxA & " " & .Filename
        End With
      Next
    End With
  Next

End Sub
Sub MergeEmailsAndForward()

  Dim AttachCrnt As Attachment
  Dim FldrNamePart() As String
  Dim FldrSrc As Outlook.Folder
  Dim FldrProc As Outlook.Folder
  Dim InxA As Long
  Dim InxFN As Long
  Dim InxI As Long
  Dim ItemCrnt As MailItem
  Dim MailItemNew As MailItem
  Dim Path As String

  Path = Environ("Temp")

  ' Create reference to source folder
  FldrNamePart = Split(FldrSrcName, "\")
  Set FldrSrc = Session.Folders(FldrNamePart(0))
  For InxFN = 1 To UBound(FldrNamePart)
    Set FldrSrc = FldrSrc.Folders(FldrNamePart(InxFN))
  Next

  ' Create reference to processed folder
  FldrNamePart = Split(FldrProcName, "\")
  Set FldrProc = Session.Folders(FldrNamePart(0))
  For InxFN = 1 To UBound(FldrNamePart)
    Set FldrProc = FldrProc.Folders(FldrNamePart(InxFN))
  Next

  Set MailItemNew = Application.CreateItem(olMailItem)

  For InxI = FldrSrc.Items.Count To 1 Step -1
    Set ItemCrnt = FldrSrc.Items(InxI)
    With ItemCrnt
      For InxA = 1 To ItemCrnt.Attachments.Count
        Set AttachCrnt = ItemCrnt.Attachments(InxA)
        With AttachCrnt
          If LCase(Right(.Filename, 4)) = ".pdf" Then
            .SaveAsFile Path & "\" & .Filename
            MailItemNew.Attachments.Add Path & "\" & .Filename, olByValue
          End If
        End With
      Next
    End With
    ItemCrnt.Move FldrProc
  Next

  With MailItemNew
    .Recipients.Add "TonyDallimore23@gmail.com"
    .Subject = "Reports from ABC devices " & Format(Now(), "d mmm yy")
    '.Display  ' Display for final checking
    '.Save     ' Save to Drafts for checking later
    .Send      ' Save to Outbox to be sent as soon as possible
  End With

End Sub