Question

我在outlook中有一个vba代码，用于将Outlook中的电子邮件导出到Excel电子表格中。目前代码导出所有电子邮件，尽管他们的主题。我想要做的是在我的代码中添加一个子句，该子句只会导出以“Approve”为主题的电子邮件。

有人可以告诉我如何做到这一点吗？

由于

'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

只需像这样添加If...Then子句

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

您的所有代码

'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

对于多种情况：

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

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

1 个答案: