使用 Excel Z6E3EC7E6A9F6007B0838FC0EEZ9A 在主题和附件中查找 Outlook Email 关键字

Question

我正在尝试在 Outlook 中搜索主题行中带有“Blue Recruit Req Data”的最新 email。
主题行中会有额外的词。
当找到 email 时，我需要验证它是否有附件。

我想将主题和接收日期存储在变量中，并将它们与之前存储在运行宏的 Excel 文件中的主题和日期进行比较。

如果主题行不匹配并且 email 的日期晚于上次存储在 Excel 文件中的日期，那么我想将该附件保存在一个文件夹中。

它没有找到主题中包含“Blue Recruit Req Data”的电子邮件。

Sub CheckEmail_BlueRecruit()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim olAp As Object, olns As Object, olInb As Object
    Dim olItm As Object, olAtch As Object, olMail As Object
    'Outlook Variables for email
    Dim sSubj As String, dtRecvd As String
    Dim oldSubj As String, olddtRecvd As String

    Sheets("Job Mapping").Visible = True
    Sheets("CC Mapping").Visible = True
    Sheets("Site Mapping").Visible = True
    Sheets("Historical Blue Recruit Data").Visible = True
    Sheets("Historical HRT Data").Visible = False
    Sheets("Combined Attrition Data").Visible = True

    Sheets.Add Before:=Sheets(1)

    'Designate ECP Facilities Model file as FNAME
    myPath = ThisWorkbook.Path
    MainWorkbook = ThisWorkbook.Name
    
    Range("A1").Select
    ActiveCell.FormulaR1C1 = myPath
    
    'designate file path for Attrition Files
    FacModPath = Cells(1, 1).Value
    Sheets(1).Delete

    'Get Outlook Instance
    Set olAp = GetObject(, "Outlook.application")
    Set olns = olAp.GetNamespace("MAPI")
    Set olInb = olns.GetDefaultFolder(6)
    Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
    
    'Chec if there are any matching emails
    If Not (olMail Is Nothing) Then

        For Each olItm In olMail
            If myItem.Attachments.Count <> 0 Then
                dtRecvd = olItm.ReceivedTime
                sSubj = olItm.Subject
                oldSubj = Sheets("CC Mapping").Range("M2").Value
                olddtRecvd = Sheets("CC Mapping").Range("M3").Value
                If sSubj = oldSubj Or dtRecvd <= olddtRecvd Then
                    MsgBox "No new Blue Recruit data files to load."
                    Exit Sub
                Else
                    Range("M2").Select
                    ActiveCell.FormulaR1C1 = sSubj
                    Range("M3").Select
                    ActiveCell.FormulaR1C1 = dtRecvd
                    For Each myAttachment In myItem.Attachments
                        If InStr(myAttachment.DisplayName, ".xlsx") Then
                            I = I + 1
                            myAttachment.SaveAs Filename:=FacModPath & "\" & myAttachment.DisplayName
                            Exit For
                        Else
                            MsgBox "No attachment found."
                            Exit For
                        End If
                    Next
                End If
            End If
        Next
    
    Else
    
        MsgBox "No emails found."
        Exit Sub
    
    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

一个单独但相关的问题。 我想搜索 Outlook 存档文件夹甚至收件箱子文件夹中的电子邮件。 我需要以不同的方式格式化这行代码吗？

Set olInb = olns.GetDefaultFolder(6)

Answer 1

当然，遍历文件夹中的所有项目并不是一个好主意。 您需要使用 Items class 的Restrict或Find / FindNext方法来仅获取与您的条件相对应的项目。 在以下文章中阅读有关这些方法的更多信息：

• 如何：使用 Find 和 FindNext 方法从文件夹中检索 Outlook 邮件项目（C#、VB.NET）
• 如何：使用限制方法从文件夹中检索 Outlook 邮件项目

在上面发布的代码中，我注意到以下行：

Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")

请注意， Restrict方法返回Items class 的实例，其中包含与您的条件相对应的项目集合，而不是您想象的单个项目。 例如：

Sub MoveItems()  
    Dim myNamespace As Outlook.NameSpace  
    Dim myFolder As Outlook.Folder  
    Dim myItems As Outlook.Items  
    Dim myRestrictItems As Outlook.Items  
    Dim myItem As Outlook.MailItem  

    Set myNamespace = Application.GetNamespace("MAPI")  
    Set myFolder = _  
        myNamespace.GetDefaultFolder(olFolderInbox)  
    Set myItems = myFolder.Items  
    Set myRestrictItems = myItems.Restrict("[Subject] = ""*Blue Recruit Req Data*""")  
    For i =  myRestrictItems.Count To 1 Step -1  
        myRestrictItems(i).Move myFolder.Folders("Business")  
    Next  
End Sub

另外，我会更改过滤器字符串以包含可能包含传递的 substring 的条目：

filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & wordsInSubject & " %'"

要获得排序的项目，即从最近或最旧的项目开始，您需要使用Items class 的Sort方法对集合进行排序：

Items.Sort("[ReceivedTime]")

最后，您可能还会发现应用程序 class 的AdvancedSearch方法很有帮助。 在 Outlook 中使用AdvancedSearch方法的主要好处是：

• 搜索在另一个线程中执行。 您不需要手动运行另一个线程，因为AdvancedSearch方法会在后台自动运行它。
• 可以在任何位置搜索任何项目类型：邮件、约会、日历、便笺等，即超出某个文件夹的 scope。 Restrict和Find / FindNext方法可以应用于特定的Items集合（请参阅 Outlook 中Folder class 的Items属性）。
• 完全支持 DASL 查询（自定义属性也可用于搜索）。 您可以在 MSDN 中的过滤文章中阅读有关此内容的更多信息。 为了提高搜索性能，如果为商店启用了Instant Search ，则可以使用Instant Search关键字（请参阅Store类的IsInstantSearchEnabled属性）。
• 您可以随时使用Search class 的Stop方法停止搜索过程。

阅读有关AdvancedSearch方法的更多信息，并以编程方式在 Outlook 中的高级搜索中找到示例代码：C#、VB.NET文章。

Answer 2

我已经重构了您的一些代码，以便您可以利用调用过程并组织您的逻辑。

虽然我没有包含你所有的代码，但正如我所见，你有足够的知识让它工作。

几个建议：

1- 在模块顶部使用option explicit 2- 尝试将变量定义为有意义的东西（使用任何人都能理解的名称） 3- 尝试一致地缩进代码（您可以使用RubberDuck

在粘贴代码之前：

使用早期绑定设置对 Outlook object 库的引用并利用智能感知和其他好处

1) 点击工具 | 参考

2）检查微软Outlook XXX Object库

---

这是重构的代码：

使用F8键执行它并调整它以满足您的需要

Public Sub CheckEmail_BlueRecruit()

    ' Declare objects
    Dim outlookApp As Outlook.Application
    Dim outlookNamespace As Outlook.Namespace
    Dim outlookFolder As Outlook.MAPIFolder

    ' Declare other variables
    Dim filterKeywords As String
    Dim filter As String

    ' Init objects
    Set outlookApp = New Outlook.Application
    Set outlookNamespace = Outlook.GetNamespace("MAPI")
    Set outlookFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)

    ' Init other variables
    filterKeywords = "financial"
    filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & filterKeywords & " %'"


    ' Loop through folders
    LoopFolders outlookFolder, filter


End Sub

Private Sub LoopFolders(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)

    ' DeclareObjects
    Dim outlookSubFolder As Outlook.MAPIFolder
    Dim outlookMail As Outlook.MailItem

    ProcessFolder outlookFolder, filter

    If outlookFolder.Folders.Count > 0 Then
        For Each outlookSubFolder In outlookFolder.Folders
            LoopFolders outlookSubFolder, filter
        Next
    End If

End Sub

Private Sub ProcessFolder(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)

    Dim outlookItems As Outlook.Items
    Dim outlookMail As Outlook.MailItem

    ' Filter folder
    Set outlookItems = outlookFolder.Items.Restrict(filter)

    If Not outlookItems Is Nothing Then

        For Each outlookMail In outlookItems

            If outlookMail.Attachments.Count <> 0 Then

                Debug.Print outlookMail.Subject

            End If

        Next outlookMail

    End If

End Sub

让我知道它是否有效，您需要更多帮助