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"替换为您的文件夹来按名称检索任何文件夹选择。

VBA使用主题和特定Outlook帐户中的某些关键字提取Outlook消息以获得优势？

1 个答案: