Outlook .ReportItem sender

[fivebs]

I wish to create a pivot of the message receipts in an Outlook folder. I am coding in Excel so that the code can be run by anyone in the department without adding code to their Outlook profile.
Using code that I have already got working for checking Categories in another folder I have modified it to check message receipts:

Dim olApp As Object, olNS As Object, olMail As Object, eFldr As Object
Dim LstColumn As Integer, Arr() As Variant, SrtRng As Range, slac As Date
Dim rngArray As Variant, strSorted As String
' Set the reference to outlook or create one
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
' Set the reference to the oulook MAPI namespace
Set olNS = olApp.GetNamespace("MAPI")
' Define the generic Mailbox name
MBG = "Mailbox - Sales Support"
Set eFldr = olNS.Folders(MBG).Folders("Inbox").Folders("Read Receipts")
Application.StatusBar = "Removing previous data..."
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Worksheets("Data").Cells.Delete
Worksheets("Collect data").Activate
Application.StatusBar = "Gathering data from Outlook..."
Worksheets("Data").Activate
With Range("F:F")
    .ColumnWidth = 18
    .NumberFormat = "dd/mm/yyyy hh:mm:ss"
End With
Range("A1") = MBG
Range("E1") = "Ran"
Range("F1") = Now()
Range("A2") = "Total Items"
Range("B2") = eFldr.items.Count
Range("A3") = "Total Unread items"
Range("B3") = eFldr.UnReadItemCount
Range("A5") = "From"
Range("B5") = "Subject"
Range("C5") = "Received"
Range("A1:A3").Font.Bold = True
Range("E1:E2").Font.Bold = True
Range("A5:K5").Font.Bold = True
' Cycle through the emails in the generic mailbox, Exception folder
rn = 6
For Each omessage In eFldr.items
    Application.StatusBar = "Reading message " & rn - 5 & " of " & eFldr.items.Count
    With omessage
'        Range("A" & rn) = .ReceivedByName
'        Range("A" & rn) = .SenderName
        Range("B" & rn) = .Subject
    End With
    rn = rn + 1
    DoEvents
Next omessage
'Create Pivot Table
Application.StatusBar = "Creating pivot table..."
Application.DisplayAlerts = False
Worksheets("Pivot").Delete
Application.DisplayAlerts = True
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
sData = Selection.Address
Sheets.Add
nSheet = "Pivot"
ActiveSheet.Name = nSheet
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=sData, Version:=xlPivotTableVersion10).CreatePivotTable TableDestination:=nSheet & "!R3C1", DefaultVersion:=xlPivotTableVersion10
pName = "PivotTable1"
ActiveSheet.PivotTables(1).Name = pName
Cells(3, 1).Select
Set pt = ActiveSheet.PivotTables(pName)
pt.AddDataField pt.PivotFields("Subject"), "Count of Subject", xlCount
pt.PivotFields("Subject").Orientation = xlRowField
Application.StatusBar = "Complete"
Set olApp = Nothing
Set olNS = Nothing
Set olMail = Nothing
Set eFldr = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = ""

The problem is that I am now checking ReportItems rather than MessageItems so .ReceivedByName and .SenderName do not work.
Searching for a solution I found that the use of CDO or Redemption seems to be the answer but, as all example code is Outlook centric, I can't fathom where to start.
Perhaps you guys can give me a pointer

 

[fivebs]

Well after much searching and testing an frustration I finally found that .PropertyAccessor.GetProperty("Error") as a workaround. Parsing the Internet Headers is not the best solution but it does the job in this case.

Here is the code so far so the next guy can use it:

rn = 6
For Each omessage In eFldr.items
    With omessage
        sc = InStr(1, .Subject, ":")
        If sc > 0 Then
            s = Left(.Subject, sc - 1)
            If s = "Read" Or s = "Not read" Then
                Set olkPA = .PropertyAccessor
                InetH = .PropertyAccessor.GetProperty("[url=http://schemas.microsoft.com/mapi/proptag/0x007D001E]Error[/url]")
                fStrt = InStr(1, InetH, "From: """)
                If fStrt > 0 Then
                    fLn = InStr(fStrt, InetH, "<") - fStrt
                    r = Right(.Subject, Len(.Subject) - sc)
                    bl = Len(.body)
                    br = Right(.body, bl - 25)
                    d = InStr(1, br, ",") + 1
                    rDtTm = Mid(br, d, InStr(d, br, " (GMT)") - d)
                    rDT = Format(CDate(rDtTm), "dd/mm/yy")
                    rTm = TimeValue(rDtTm)
                    Range("A" & rn) = Mid(InetH, fStrt + 7, fLn - 9)
                    Range("B" & rn) = s
                    Range("C" & rn) = rDT
                    Range("D" & rn) = rTm
                    Range("E" & rn) = r
                    Range("F" & rn) = InetH
                    rn = rn + 1
                End If
            End If
        End If
    End With
    DoEvents
Next omessage

 

[DeusXv]

Thanks for posting a solution to the problem, might come in handy some time in the future.