Outlook 365 VBA-搜索今天发送的邮件'；日期和具体主题。如果未找到，请发送电子邮件

我是Outlook VBA宏的新手。我正在尝试添加一个函数，其中

1） 当Outlook打开时，它将搜索具有特定主题的当前日期的已发送邮件。 2） 如果没有找到，则发送“测试”电子邮件 3） 如果找到，只需显示写着“找到电子邮件”的消息框

到目前为止，我只能做到1

更新：
这就是我尝试过的。它似乎没有搜索带有主题的“已发送邮件”文件夹

Public Function is_email_sent()
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olFldr As Outlook.Folder
    Dim olItms As Outlook.Items
    Dim objItem As Outlook.MailItem

    On Error Resume Next

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set olFldr = olNs.GetDefaultFolder(Outlook.olFolderSentMail)

    For Each objItem In olFldr.Items
      If objItem.Subject = "Test Alert" And _
      objItem.SentOn = Date Then _

      MsgBox "Yes. Email found"

      Else
          MsgBox "No. Email not found"
          Exit For             
      End If

    Next objItem
End Function

---

这是我使用的一些代码

Sub sendmail10101() 'this  is to send the email from contents in a cell

    Dim obApp As Object
    Dim NewMail As MailItem

    Set obApp = Outlook.Application
    Set NewMail = obApp.CreateItem(olMailItem)

    'You can change the concrete info as per your needs
    With NewMail
         .Subject = Cells(21, 3).Value
         .To = Cells(18, 3).Value
         .Body = "Good day" & vbCrLf & "i hope you are keeping well " & vbCrLf & vbCrLf & "please can you assist with the below members infomation;" & vbCrLf & vbCrLf & vbCrLf & Cells(20, 3).Value
         '.Attachments.Add ("C:\Attachments\Test File.docx")
         .Importance = olImportanceHigh
         .Display
    End With

    Set obApp = Nothing
    Set NewMail = Nothing

End Sub

下一部分是搜索邮箱，您也可以使用它从第一个初始单元格进行搜索

Option Explicit
Public Sub Search_Outlook_Emails()
 Dim outApp As Outlook.Application
 Dim outNs As Outlook.Namespace
 Dim outStartFolder As Outlook.MAPIFolder
 Dim foundEmail As Outlook.MailItem

 Set outApp = New Outlook.Application
 Set outNs = outApp.GetNamespace("MAPI")

 'Start at Inbox's parent folder
 Set outStartFolder = outNs.GetDefaultFolder(Outlook.olFolderInbox).Parent

 'Or start at folder selected by user
 'Set outStartFolder = outNs.PickFolder
 If Not outStartFolder Is Nothing Then

 Set foundEmail = Find_Email_In_Folder(outStartFolder, ThisWorkbook.Sheets("Dashboard").TextBox1.Value)



 If Not foundEmail Is Nothing Then

 If MsgBox("Email subject: " & foundEmail.Subject & vbNewLine & vbNewLine & _
 "Folder: " & foundEmail.Parent.FolderPath & vbNewLine & vbNewLine & _
 "Open the email?", vbYesNo, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' found") = vbYes Then

 foundEmail.Display

 End If
 Else

 MsgBox "", vbOKOnly, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' not found"

 End If

 End If
End Sub
Private Function Find_Email_In_Folder(outFolder As Outlook.MAPIFolder, findText As String) As Outlook.MailItem

 Dim outItem As Object
 Dim outMail As Outlook.MailItem
 Dim outSubFolder As Outlook.MAPIFolder
 Dim i As Long

 Debug.Print outFolder.FolderPath

 Set Find_Email_In_Folder = Nothing

 'Search emails in this folder

 i = 1
 While i <= outFolder.Items.Count And Find_Email_In_Folder Is Nothing

 Set outItem = outFolder.Items(i)

 If outItem.Class = Outlook.OlObjectClass.olMail Then

 'Does the findText occur in this email's body text?

 Set outMail = outItem
 If InStr(1, outMail.Body, findText, vbTextCompare) > 0 Then Set Find_Email_In_Folder = outMail

 End If

 i = i + 1

 Wend

 DoEvents

 'If not found, search emails in subfolders

 i = 1
 While i <= outFolder.Folders.Count And Find_Email_In_Folder Is Nothing

 Set outSubFolder = outFolder.Folders(i)

 'Only check mail item folders

 If outSubFolder.DefaultItemType = Outlook.olMailItem Then Set Find_Email_In_Folder = Find_Email_In_Folder(outSubFolder, findText)

 i = i + 1

 Wend

End Function

或者，如果没有消息框，则使用诸如“如果找到”之类的内容

---

希望这有帮助

主要错误是错误恢复时误用了

。错误被绕过，而不是修复

Public Sub is_email_sentFIX()

    Dim olFldr As Folder
    Dim olItms As Items

    Dim objItem As Object

    Dim bFound As Boolean

    ' Not useful here.
    ' Use for specific purpose to bypass **expected** errors.
    'On Error Resume Next

    Set olFldr = Session.GetDefaultFolder(olFolderSentMail)

    Set olItms = olFldr.Items

    olItms.sort "[SentOn]", True

    For Each objItem In olItms

        If objItem.Class = OlMail Then

            Debug.Print objItem.Subject

            If objItem.Subject = "Test Alert" Then

                Debug.Print objItem.SentOn
                Debug.Print Date

                If objItem.SentOn > Date Then
                    MsgBox "Yes. Email found"
                    bFound = True
                    Exit For
                End If

            End If

        End If

    Next objItem

    If bFound = False Then
        MsgBox "No. Email not found"
    End If

End Sub

如果“已发送”文件夹中的项目过多，“未找到”结果将很慢

暴力方式的一个可能选项是
将
限制为特定项，而不是使用If语句。
我想我可以使用一些代码，尽管我尝试仅在Outlook 365中运行这些代码。会让你知道它是否有效。非常感谢。令人惊叹的！非常感谢。我刚刚添加了一个条件，在没有找到电子邮件时发送电子邮件，并在应用程序启动（）上调用Sub is_email_sentFIX（）。
with activeworkbook

if msgbox.value = "yes" then
range("A1:A30") = "COMPLETED" 'ASSUMING THIS IS THE INTIAL TEST RANGE IT WILL CHANGE THE SUBJECT THUS STOPPING THE FIRST MACRO

end if 
end with

Public Sub is_email_sentFIX()

    Dim olFldr As Folder
    Dim olItms As Items

    Dim objItem As Object

    Dim bFound As Boolean

    ' Not useful here.
    ' Use for specific purpose to bypass **expected** errors.
    'On Error Resume Next

    Set olFldr = Session.GetDefaultFolder(olFolderSentMail)

    Set olItms = olFldr.Items

    olItms.sort "[SentOn]", True

    For Each objItem In olItms

        If objItem.Class = OlMail Then

            Debug.Print objItem.Subject

            If objItem.Subject = "Test Alert" Then

                Debug.Print objItem.SentOn
                Debug.Print Date

                If objItem.SentOn > Date Then
                    MsgBox "Yes. Email found"
                    bFound = True
                    Exit For
                End If

            End If

        End If

    Next objItem

    If bFound = False Then
        MsgBox "No. Email not found"
    End If

End Sub