VBA提取outlook信息以便在主題和某個特定的Outlook帳戶中使用某些kewords字詞？

Question

我有這個vba代碼，我在Outlook中使用它將某個主題行的所有電子郵件導出爲ex​​cel。我目前有自己的代碼設置，可以在當時從當前活動的文件夾中導出電子郵件，但是我想更改此選項，以便只選擇帳戶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"來按名稱檢索任何文件夾。