Получение ответов на голосование по разным отправленным письмам на одну тему

Question

Sub ExportVotingStatistics_Excel()
    Dim objRecipient As Outlook.Recipient
    Dim objVoteDictionary As Object
    Dim varVotingCounts As Variant
    Dim varVotingOptions As Variant
    Dim varVotingOption As Variant
    Dim i As Long
    Dim nRow As Integer
    Dim olapp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim OutlookApp As Outlook.Application
    Dim OutlookNameSpace As Namespace
    Dim Folder As MAPIFolder
    Dim OutlookMail As Variant

Set olMail = Outlook.Application.ActiveExplorer.Selection(1)

Set OutlookApp = New Outlook.Application
Set OutlookNameSpace = OutlookApp.GetNamespace("MAPI")

Set Folder = OutlookNameSpace.GetDefaultFolder(olFolderInbox)


    'Fill in the predefined values
    Worksheets("Mail-Extraction").Activate
    With ActiveSheet
         .Cells.Font.Name = "Calibri"
         .Cells(1, 1) = "Voting Results for Email:"
         .Cells(1, 2) = "Company follow-up with client"
         .Cells(3, 1) = "Voting Options"
         .Cells(3, 2) = "Voting Recepient"
    End With
Set objVoteDictionary = CreateObject("Scripting.Dictionary")
'get the default voting options
varVotingOptions = Split(olMail.VotingOptions, ";")
'Add the voting responses to the dictionary
For Each varVotingOption In varVotingOptions
    objVoteDictionary.Add varVotingOption, 0
Next
'Add a custom voting response - "No Reply"
objVoteDictionary.Add "No Reply", 0

'Process all the voting responses
For Each olMailRecepient In olMail.Recipients
    If olMailRecepient.TrackingStatus = olTrackingReplied And olMail.Subject = "3rd follow-up with Sales Team Member" Then
'For Each OutlookMail In Folder.Items
'    If OutlookMail.Subject = "3rd follow-up with Sales Team Member" And OutlookMail.ReceivedTime = #2/17/2020# Then
        If objVoteDictionary.Exists(olMailRecepient.AutoResponse) Then
            objVoteDictionary.Item(olMailRecepient.AutoResponse) = objVoteDictionary.Item(olMailRecipient.AutoResponse) + 1
        Else
            objVoteDictionary.Add olMailRecepient.AutoResponse, 1
        End If
    End If
Next
'Get the voting options and Vote counts
varVotingOptions = objVoteDictionary.Keys
varVotingCounts = objVoteDictionary.Items

'Fill in the values in specific cells
    nRow = 4
    For i = LBound(varVotingOptions) To UBound(varVotingOptions)
        With ActiveSheet
             .Cells(nRow, 1) = olMail.VotingResponse
             .Cells(nRow, 2) = olMail.SenderName
        End With
        nRow = nRow + 1
    Next

End Sub

Приведенный выше код просто дает ответ на голосование для почты, которую я выбрал в настоящее время, а не для всего почтового каталога.

Answer 1

Ну, конечно, ваш код работает только с текущим выбранным сообщением, возвращаемым Outlook.Application.ActiveExplorer.Selection.

Добавить все oop поверх элементов папки «Входящие»:

dim item As Object
...
for each item in Folder.Items
  if item.Class = 43 Then
    set olMail  = item
    For Each olMailRecepient In olMail.Recipients
      ...
    next
  End If
next