在Excel中使用VBA查找在主题行和附件中具有特定关键字的Outlook电子邮件

Question

[在Excel中使用宏，我正在尝试在Outlook中搜索主题行中带有“ Blue Recruit Req Data”的最新电子邮件，但是主题行中还会有其他单词，因此需要搜索包含该字符串，但与该字符串不完全匹配。另外，当在主题行中找到带有“ Blue Recruit Req Data”字符串的电子邮件时，我需要验证它是否具有附件。如果找到主题行并且电子邮件中包含附件，那么我想将主题和收到的日期存储在变量中，并将它们与运行宏的Excel文件中存储的以前的主题和日期进行比较。如果主题行不匹配且电子邮件的日期晚于最后一次存储在excel文件中的日期，那么我想将该附件保存在文件夹中。我遇到的问题是找不到主题中包含“ Blue Recruit Req Data”的任何电子邮件，但是我知道Outlook中有多封电子邮件，主题行中带有该短语。关于我未正确编码或缺少编码的任何建议？

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存档文件夹中或什至Inbox子文件夹中的电子邮件，是否需要对这行代码进行不同的格式设置？

Set olInb = olns.GetDefaultFolder(6)

Answer 1

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

Answer 2

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