尝试使用VBA收集电子邮件统计信息时出错
我正在尝试编写一个VBA脚本来收集一天中共享邮箱的指标。 从本质上讲，我想要导出到Excel在一天中的不同时间检测到多less新的，发送和接收的邮件。
我正在使用下面的代码，但是当我尝试运行脚本时出现错误。 错误状态：
“运行时错误”13“types不匹配”
debugging将突出显示Next olMail的错误。
有没有人有任何想法是什么导致这个错误，或者如果我需要从这个方向从另一个方向？ 此外，我不相信我有我的共享邮箱正确的设置，因为我的默认电子邮件不共享。 我怎么需要修改Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)的脚本来识别我需要它来阅读共享框？
我正在使用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
我想如果我能得到上面的工作，我可以拼凑在Excel中的rest，但如果有人知道更好的方式任何build议，绝对赞赏。
最后，如果我想将脚本的能力添加到单个子文件夹和/或类别的导出信息，我该从哪里开始？ 这可能吗？
任何一点正确的方向，我将非常感激。
在此链接上使用@Dmitry Streblechenko给出的答案： 获取对其他收件箱的引用
我已经包含Sue Mosher的ResolveDisplayNameToSMTP函数来环绕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