VBA 使用主题中的某些关键字和特定的 Outlook 帐户提取 Outlook 消息以使其表现出色？

Question

我有这个 vba 代码，我在 Outlook 中使用它来将具有特定主题行的所有电子邮件导出到 Excel。我目前有我的代码设置以从当前活动文件夹中导出电子邮件，但是我想更改此设置，以便仅选择来自帐户 NewSupplier@hewden.co.uk 下的收件箱文件夹的电子邮件，并且所有其余被忽略。有人可以告诉我怎么做吗？

谢谢

'On the next line edit the path to the spreadsheet you want to export to
    Const WORKBOOK_PATH = "X:\New_Supplier_Set_Ups_&_Audits\NewSupplierSet-Up.xls"
    'On the next line edit the name of the sheet you want to export to
    Const SHEET_NAME = "Validations"
    Const MACRO_NAME = "Export Messages to Excel (Rev 7)"

    Sub ExportMessagesToExcel()
        Dim olkMsg As Object, _
            excApp As Object, _
            excWkb As Object, _
            excWks As Object, _
            intRow As Integer, _
            intExp As Integer, _
            intVersion As Integer
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
        Set excWks = excWkb.Worksheets(SHEET_NAME)
        intRow = excWks.UsedRange.Rows.Count + 1
       'Write messages to spreadsheet
            For Each olkMsg In Application.ActiveExplorer.Inbox.Items
                'Only export messages, not receipts or appointment requests, etc.
                If olkMsg.class = olMail Then
                If olkMsg.Subject Like "Accept: New Supplier Request*" Or olkMsg.Subject Like "Reject: New Supplier Request*" Then
                        'Add a row for each field in the message you want to export
                        excWks.Cells(intRow, 1) = olkMsg.ReceivedTime
                        Dim LResult As String
                        LResult = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
                        LResult = Left(LResult, InStrRev(LResult, "@") - 1)
                        excWks.Cells(intRow, 2) = LResult
                        excWks.Cells(intRow, 3) = olkMsg.VotingResponse
                        Dim s As String
                        s = olkMsg.Subject
                        Dim indexOfName As Integer
                        indexOfName = InStr(1, s, "Reference: ")
                        Dim finalString As String
                        finalString = Right(s, Len(s) - indexOfName - 10)
                        excWks.Cells(intRow, 4) = finalString
                        intRow = intRow + 1
                    End If
                End If
            Next
                    Set olkMsg = Nothing
        excWkb.Close True
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
        MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
    End Sub

    Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
        Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
        On Error Resume Next
        Select Case intOutlookVersion
            Case Is < 14
                If Item.SenderEmailType = "EX" Then
                    GetSMTPAddress = SMTP2007(Item)
                Else
                    GetSMTPAddress = Item.SenderEmailAddress
                End If
            Case Else
                Set olkSnd = Item.Sender
                If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                    Set olkEnt = olkSnd.GetExchangeUser
                    GetSMTPAddress = olkEnt.PrimarySmtpAddress
                Else
                    GetSMTPAddress = Item.SenderEmailAddress
                End If
        End Select
        On Error GoTo 0
        Set olkPrp = Nothing
        Set olkSnd = Nothing
        Set olkEnt = Nothing
    End Function

    Function GetOutlookVersion() As Integer
        Dim arrVer As Variant
        arrVer = Split(Outlook.Version, ".")
        GetOutlookVersion = arrVer(0)
    End Function

    Function SMTP2007(olkMsg As Outlook.MailItem) As String
        Dim olkPA As Outlook.PropertyAccessor
        On Error Resume Next
        Set olkPA = olkMsg.PropertyAccessor
        SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
        On Error GoTo 0
        Set olkPA = Nothing
    End Function

Answer 1

在代码中，我相信这一行根本不起作用，因为Inbox 不是ActiveExplorer 对象的属性。在没有更多信息的情况下，我将建议我认为你需要用什么来替换它以获得你想要的行为。

For Each olkMsg In Application.ActiveExplorer.Inbox.Items

删除此行，取而代之的是检索您想要的帐户的收件箱，方法是将其替换为：

Dim Ns As Outlook.NameSpace
Dim Items As Outlook.Items

' Get the MAPI Namespace
Set Ns = Application.GetNamespace("MAPI")
' Get the Items for the Inbox in the specified account
Set Items = Ns.Folders("accountname here").Folders("Inbox").Items

' Start looping through the items 
For Each olkMsg In Items

accountname here 替换为您希望访问其中的Inbox 文件夹的帐户名称。您可以通过将"Inbox" 替换为您选择的文件夹来按名称检索任何文件夹。