Question

每次收到新邮件时，我都会自动将电子邮件详细信息从Outlook导出到Excel。电子邮件正确导出到Excel中。

我希望优化代码，以便只将具有特定主题的邮件导出到Excel中。

使用的代码如下：

Public WithEvents objMails As Outlook.Items

Private Sub Application_Startup()
    Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objMails_ItemAdd(ByVal Item As Object)
    Dim objMail As Outlook.MailItem
    Dim strExcelFile As String
    Dim objExcelApp As Excel.Application
    Dim objExcelWorkBook As Excel.Workbook
    Dim objExcelWorkSheet As Excel.Worksheet
    Dim nNextEmptyRow As Integer
    Dim strColumnB As String
    Dim strColumnC As String
    Dim strColumnD As String
    Dim strColumnE As String
    Dim strColumnF As String

    If Item.Class = olMail Then
       Set objMail = Item
    End If

    'Specify the Excel file which you want to auto export the email list
    'You can change it as per your case
    strExcelFile = "C:\Users\pddamoda\Desktop\abc.xlsx"

    'Get Access to the Excel file
    On Error Resume Next
    Set objExcelApp = GetObject(, "Excel.Application")
    If Error <> 0 Then
       Set objExcelApp = CreateObject("Excel.Application")
    End If
    Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
    Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")

    'Get the next empty row in the Excel worksheet
    nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1

    'Specify the corresponding values in the different columns
    strColumnB = objMail.SenderName
    strColumnC = objMail.SenderEmailAddress
    strColumnD = objMail.Subject
    strColumnE = objMail.ReceivedTime
    strColumnF = objMail.Body

    'Add the vaules into the columns
    objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
    objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
    objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
    objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
    objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE
    objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF

    'Fit the columns from A to E
    objExcelWorkSheet.Columns("A:F").AutoFit

    'Save the changes and close the Excel file
    objExcelWorkBook.Close SaveChanges:=True
End Sub

Answer 1

以下是使用Item.Restrict的示例，当您拥有较大的搜索范围时，Restrict会更好。您可以阅读此帖子以获取更多信息：Find an email starting with specific subject using VBA

sub exampleFilter()

Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim eFilter As String

Set myOlApp = GetObject(, "Outlook.Application")


Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

Dim emailSubject As String
emailSubject = "The Subject You like to Filter"

eFilter = "@SQL=" &    Chr(34) & "urn:schemas:httpmail:subject" & _
                       Chr(34) & " = '" + emailSubject + "'"    

Set filteredItems = objFolder.Items.Restrict(eFilter)

If filteredItems.Count = 0 Then
    debug.print "No Email with that subject found"
Else
    For Each itm In filteredItems
     Debug.Print itm.Subject
    Next
End If


If filteredItems.Count <> 0 Then
   Debug.Print "Found " & filteredItems.Count & " items."
End If

End Sub

按主题识别收到的邮件

1 个答案: