Макрос Outlook для определения писем, отправитель которых также является получателем

Question

Я пытаюсь создать макрос, который будет экспортировать детали моих писем в Excel. В частности, мне нужны адрес электронной почты отправителя и адреса электронной почты получателя (до и cc). Мне удалось адаптировать код, который я нашел в Интернете, - теперь он делает большую часть того, что мне нужно, но есть две проблемы: - Он работает только с одним получателем. Если есть 2 или более получателей, он просто указывает их имена (например, Джо Блоггс) вместо своих адресов электронной почты. - Он включает в себя только людей в поле «Кому», а не людей в поле «CC»

Я скопировал полный код ниже, но я думаю, что конкретный бит, который нужно исправить, -

'trying to get recipient email address
 Dim olEU2 As Outlook.ExchangeUser
 Dim oEDL2 As Outlook.ExchangeDistributionList
 Dim recip2 As Outlook.Recipient
 Set recip2 = Application.Session.CreateRecipient(strColE)

     Select Case recip2.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU2 = recip.AddressEntry.GetExchangeUser
         If Not (olEU2 Is Nothing) Then
             strColE = olEU2.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU2 = recip.AddressEntry.GetExchangeUser
         If Not (olEU2 Is Nothing) Then
            strColE = olEU2.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL2 Is Nothing) Then
            strColE = olEU2.PrimarySmtpAddress
         End If
     End Select

Полный код:

Option Explicit
 Sub CopyToExcel()
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String

Dim objOL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
 Dim obj As Object
 Dim olItem 'As Outlook.MailItem
 Dim strColA, strColB, strColC, strColD, strColE, strColF As String

' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Book1.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0

On Error Resume Next
  ' Open the workbook to input the data
  ' Create workbook if doesn't exist
     Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
      xlWB.SaveAs FileName:=strPath
End If
   On Error GoTo 0
     Set xlSheet = xlWB.Sheets("Sheet1")

On Error Resume Next
' add the headers if not present
If xlSheet.Range("A1") = "" Then
  xlSheet.Range("A1") = "Sender Name"
  xlSheet.Range("B1") = "Sender Email"
  xlSheet.Range("C1") = "Subject"
  xlSheet.Range("D1") = "Body"
  xlSheet.Range("E1") = "Sent To"
  xlSheet.Range("F1") = "Date"
End If

'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
    Set objItems = objFolder.Items
  For Each obj In objItems

    Set olItem = obj

 'collect the fields

    strColA = olItem.SenderName
    strColB = olItem.SenderEmailAddress
    strColC = olItem.Subject
    strColD = olItem.Body
    strColE = olItem.To
    strColF = olItem.ReceivedTime


' Get the Exchange address
' if not using Exchange, this block can be removed
 Dim olEU As Outlook.ExchangeUser
 Dim oEDL As Outlook.ExchangeDistributionList
 Dim recip As Outlook.Recipient
 Set recip = Application.Session.CreateRecipient(strColB)

 If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
     Select Case recip.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
     End Select
End If
' End Exchange section


'trying to get recipient email address
 Dim olEU2 As Outlook.ExchangeUser
 Dim oEDL2 As Outlook.ExchangeDistributionList
 Dim recip2 As Outlook.Recipient
 Set recip2 = Application.Session.CreateRecipient(strColE)

     Select Case recip2.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU2 = recip.AddressEntry.GetExchangeUser
         If Not (olEU2 Is Nothing) Then
             strColE = olEU2.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU2 = recip.AddressEntry.GetExchangeUser
         If Not (olEU2 Is Nothing) Then
            strColE = olEU2.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL2 Is Nothing) Then
            strColE = olEU2.PrimarySmtpAddress
         End If
     End Select



'write them in the excel sheet
  xlSheet.Range("A" & rCount) = strColA
  xlSheet.Range("B" & rCount) = strColB
  xlSheet.Range("c" & rCount) = strColC
  xlSheet.Range("d" & rCount) = strColD
  xlSheet.Range("e" & rCount) = strColE
  xlSheet.Range("f" & rCount) = strColF

'Next row
  rCount = rCount + 1
xlWB.Save

 Next

' don't wrap lines
xlSheet.Rows.WrapText = False

xlWB.Save
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If

     Set olItem = Nothing
     Set obj = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub

Answer 1

Перебор всех элементов в папке - не очень хорошая идея. Я бы рекомендовал начинать с Find / FindNext или Restrict методов вместо этого. Обратите внимание, что есть некоторые свойства элемента, которые вы не можете использовать для фильтра. Вы можете прочитать больше о свойствах, не разрешенных в строке фильтра и форматах строки, используемых для критерия поиска на MSDN .

В следующем примере метод Restrict используется для получения всех элементов папки «Входящие» категории «Бизнес» и их перемещения в папку Business. Для запуска этого примера создайте или убедитесь, что в папке Inbox:

Sub MoveItems()  
    Dim myNamespace As Outlook.NameSpace  
    Dim myFolder As Outlook.Folder  
    Dim myItems As Outlook.Items  
    Dim myRestrictItems As Outlook.Items  
    Dim myItem As Outlook.MailItem  

    Set myNamespace = Application.GetNamespace("MAPI")  
    Set myFolder = _  
        myNamespace.GetDefaultFolder(olFolderInbox)  
    Set myItems = myFolder.Items  
    Set myRestrictItems = myItems.Restrict("[Categories] = 'Business'")  
    For i =  myRestrictItems.Count To 1 Step -1  
        myRestrictItems(i).Move myFolder.Folders("Business")  
    Next  
End Sub

существует подпапка «Бизнес». Также вам может пригодиться метод AdvancedSearch класса Application. Основные преимущества использования метода AdvancedSearch в Outlook:

• Поиск выполняется в другом потоке. Вам не нужно запускать другой поток вручную, поскольку метод AdvancedSearch запускает его автоматически в фоновом режиме.
• Возможность поиска любых типов элементов: почта, встреча, календарь, заметки и т. Д. c. в любом месте, то есть за пределами определенной папки. Методы Restrict и Find / FindNext можно применять к определенной коллекции Items (см. Свойство Items класса Folder в Outlook).
• Полная поддержка DASL запросы (пользовательские свойства могут быть использованы для поиска). Подробнее об этом можно прочитать в статье Filtering в MSDN. Для повышения эффективности поиска можно использовать ключевые слова мгновенного поиска, если для магазина включен мгновенный поиск (см. Свойство IsInstantSearchEnabled класса Store).
• Вы можете остановить процесс поиска в любой момент. используя метод Stop класса Search.

Помните, что вы можете установить подходящий фильтр (View | View Settings | filter) для папки и изучить строку фильтра в SQL вкладка диалога Filter. Затем вы можете построить любую необходимую строку фильтра в коде.

Answer 2

Если было бы неплохо использовать Items.Find/FindNext или Items.Restrict, но я не могу придумать вопрос, который позволил бы вам делать то, что вы хотите. Если это одноразовая вещь, у вас нет выбора, кроме как l oop через все элементы в папке и для каждого элемента l oop через всех получателей и сравнить идентификатор записи каждого получателя (Recipient.EntryID) с записью отправителя. id (MailItem.Sender.EntryId).