使用VBA将电子邮件从Outlook导出到Excel电子表格

Question

I have a vba code in outlook which I am using to export emails from outlook into a Excel spreadsheet. At the moment the code exports all emails despite their subject. What I want to do is add a clause in my code which says only export the emails which have a "Approve" as a subject.

Can someone please show me how I might be able to do this?

Thanks

'On the next line edit the path to the spreadsheet you want to export to
    Const WORKBOOK_PATH = "X:\Book2.xls"
    'On the next line edit the name of the sheet you want to export to
    Const SHEET_NAME = "Sheet1"
    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.CurrentFolder.Items
                'Only export messages, not receipts or appointment requests, etc.
                If olkMsg.Class = olMail Then
                    'Add a row for each field in the message you want to export
                    excWks.Cells(intRow, 1) = olkMsg.Subject
                    excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                    excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                    excWks.Cells(intRow, 4) = olkMsg.VotingResponse
                    intRow = intRow + 1
                End If
            Next
                    Set olkMsg = Nothing
        excWkb.Close True
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
        MsgBox "Process complete.  A total of " & intExp & " messages were exported.", 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

Just add an If...Then clause like this

If olkMsg.Class = olMail Then
    If olkMsg.Subject = "Approve" Then
        'Add a row for each field in the message you want to export
        excWks.Cells(intRow, 1) = olkMsg.Subject
        excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
        excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
        excWks.Cells(intRow, 4) = olkMsg.VotingResponse
        intRow = intRow + 1
    End If
End If

All your code

'On the next line edit the path to the spreadsheet you want to export to
    Const WORKBOOK_PATH = "X:\Book2.xls"
    'On the next line edit the name of the sheet you want to export to
    Const SHEET_NAME = "Sheet1"
    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.CurrentFolder.Items
                'Only export messages, not receipts or appointment requests, etc.
                If olkMsg.Class = olMail Then
                    If olkMsg.Subject = "Approve" Then
                        'Add a row for each field in the message you want to export
                        excWks.Cells(intRow, 1) = olkMsg.Subject
                        excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                        excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                        excWks.Cells(intRow, 4) = olkMsg.VotingResponse
                        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.  A total of " & intExp & " messages were exported.", 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

For multiple condition:

If olkMsg.Class = olMail Then
    If olkMsg.Subject = "Approve" Or olkMsg.Subject= "Reject" Then
        'Add a row for each field in the message you want to export
        excWks.Cells(intRow, 1) = olkMsg.Subject
        excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
        excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
        excWks.Cells(intRow, 4) = olkMsg.VotingResponse
        intRow = intRow + 1
    End If
End If