VBA是否将outlook邮件从特定outlook帐户中提取到excel，并在主题中包含某些关键字？

我有这个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

---

在代码中，我认为这一行根本不起作用，因为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将替换为您希望访问收件箱文件夹的帐户名。通过将收件箱替换为您选择的文件夹，您可以按名称检索任何文件夹。

我很好奇，您使用的是什么版本的Outlook？我假设这段代码目前适用于您，除了它处理默认的收件箱？。我之所以问这个问题，是因为我不确定Application.ActiveExplorer.Inbox.Items这些天是否可以用来获取默认框。或者，您提供的这段代码是为了尝试获取特定的收件箱，但它不起作用？就目前情况而言，我认为您发布的代码甚至不可能在没有错误的情况下运行。