使用VBA將電子郵件從Outlook導出到Excel電子表格中

Question

我在Outlook中有一個vba代碼，用於將Outlook中的電子郵件導出到Excel電子表格中。 目前的代碼導出所有電子郵件，儘管他們的主題。 我想要做的是在我的代碼中添加一個條款，該條款只說明將具有「批准」的電子郵件導出爲主題。

有人可以告訴我我怎麼能做到這一點？

感謝

'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