Error while trying to gather email statistics using VBA - 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