Question

我尝试编写VBA脚本，以便在一天内收集共享邮箱的指标。基本上，我想要导出到Excel，在一天中的不同时间检测到多少新的，已发送的和已接收的消息。

我正在使用下面的代码，但是当我尝试运行脚本时出现错误。错误说明：

＆＃34;运行时错误＆＃39; 13＆＃39;＆＃34;类型不匹配＆＃34;

调试突出显示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中，但是如果有人知道更好的方式，任何建议都绝对值得赞赏。

最后，如果我想添加脚本功能，以便为各个子文件夹和/或类别导出此信息，我将从哪里开始？这可能吗？

正确方向的任何一点我都会非常感激。

Answer 1

使用@Dmitry Streblechenko在此链接上给出的答案：Get reference to additional Inbox

我已经包含了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

尝试使用VBA收集电子邮件统计信息时出错

1 个答案: