Error while trying to gather email statistics using VBA

Question

I'm trying to write a VBA script to gather metrics on a shared mailbox throughout the day. Essentially, I'm wanting to export to Excel how many new, sent, and received messages where detected at different times throughout the day.

I'm working with the code below, however am getting an error when I try running the script. The error states:

"Run-time error '13'" Type mismatch"

Debugging highlights the error at Next olMail.

Does anyone have any ideas on what is causing this error, or if I need to be going at this from another direction? Also, I don't believe I have this setup correctly for my shared mailbox, as my default email is not shared. How do I need to modify Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) for the script to recognize I need it to read the shared box?

I'm using Outlook 2013.

Sub EmailStats()

    Dim olMail As MailItem
    Dim aOutput() As Variant
    Dim lCnt As Long
    Dim xlApp As Excel.Application
    Dim xlSh As Excel.Worksheet
    Dim flInbox As Folder

    Set flInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

    ReDim aOutput(1 To flInbox.Items.Count, 1 To 4)

    For Each olMail In flInbox.Items
        If TypeName(olMail) = "MailItem" Then
            lCnt = lCnt + 1
            aOutput(lCnt, 1) = olMail.SenderEmailAddress 
            aOutput(lCnt, 2) = olMail.ReceivedTime 
            aOutput(lCnt, 3) = olMail.ConversationTopic 
            aOutput(lCnt, 4) = olMail.Subject 
        End If
    Next olMail

    Set xlApp = New Excel.Application
    Set xlSh = xlApp.Workbooks.Add.Sheets(1)

    xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
    xlApp.Visible = True

End Sub

I figure if I can get the above to work, I can piece together the rest in Excel, though if anyone knows a better way any advice is definitely appreciated.

Lastly, where would I start if I'd like to add the ability to the script to export this information for individual sub-folders and/or categories? Is this possible?

Any point in the right direction I would be very grateful for.

Answer 1

Using the answer given by @Dmitry Streblechenko on this link:Get reference to additional Inbox

I've included the ResolveDisplayNameToSMTP function by Sue Mosher to wrap around the SenderEmailAddress.

Sub EmailStats()

    Dim olMail As MailItem
    Dim aOutput() As Variant
    Dim ns As Outlook.NameSpace
    Dim vRecipient As Recipient
    Dim lCnt As Long
'    Dim xlApp As Excel.Application
'    Dim xlSh As Excel.Worksheet
    Dim flInbox As Folder

    Set ns = Application.GetNamespace("MAPI")
    Set vRecipient = ns.CreateRecipient("<top level folder of shared inbox>")
    If vRecipient.Resolve Then
        Set flInbox = ns.GetSharedDefaultFolder(vRecipient, olFolderInbox)
    End If

    ReDim aOutput(1 To flInbox.Items.Count, 1 To 4)

    For Each olMail In flInbox.Items
        If TypeName(olMail) = "MailItem" Then
            lCnt = lCnt + 1
            aOutput(lCnt, 1) = ResolveDisplayNameToSMTP(olMail.SenderEmailAddress, Outlook.Application)
            aOutput(lCnt, 2) = olMail.ReceivedTime
            aOutput(lCnt, 3) = olMail.ConversationTopic
            aOutput(lCnt, 4) = olMail.Subject
        End If
    Next olMail

'    Set xlApp = New Excel.Application
'    Set xlSh = xlApp.Workbooks.Add.Sheets(1)

'    xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
'    xlApp.Visible = True

End Sub

'----------------------------------------------------------------------------------
' Procedure : ResolveDisplayNameToSMTP
' Author    : Sue Mosher - updated by D.Bartrup-Cook to work in Excel late binding.
'-----------------------------------------------------------------------------------
Public Function ResolveDisplayNameToSMTP(sFromName, OLApp As Object) As String


    Select Case Val(OLApp.Version)
        Case 11 'Outlook 2003

            Dim oSess As Object
            Dim oCon As Object
            Dim sKey As String
            Dim sRet As String

            Set oCon = OLApp.CreateItem(2) 'olContactItem

            Set oSess = OLApp.GetNamespace("MAPI")
            oSess.Logon "", "", False, False
            oCon.Email1Address = sFromName
            sKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
            oCon.FullName = sKey
            oCon.Save

            sRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), sKey, ""))
            oCon.Delete
            Set oCon = Nothing

            Set oCon = oSess.GetDefaultFolder(3).Items.Find("[Subject]=" & sKey) '3 = 'olFolderDeletedItems
            If Not oCon Is Nothing Then oCon.Delete

            ResolveDisplayNameToSMTP = sRet

        Case 14 'Outlook 2010

            Dim oRecip As Object 'Outlook.Recipient
            Dim oEU As Object 'Outlook.ExchangeUser
            Dim oEDL As Object 'Outlook.ExchangeDistributionList

            Set oRecip = OLApp.Session.CreateRecipient(sFromName)
            oRecip.Resolve
            If oRecip.Resolved Then
                Select Case oRecip.AddressEntry.AddressEntryUserType
                    Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
                        Set oEU = oRecip.AddressEntry.GetExchangeUser
                        If Not (oEU Is Nothing) Then
                            ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
                        End If
                    Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
                            ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
                End Select
            End If
        Case Else
            'Name not resolved so return sFromName.
            ResolveDisplayNameToSMTP = sFromName
    End Select
End Function