Question

我是Outlook VBA宏的新手。我正在尝试在其中添加功能

1）当Outlook打开时，它将搜索发送的项目中具有特定主题的今天的日期。 2）如果未找到，则发送“测试”电子邮件 3）如果找到，则只显示显示“找到电子邮件”的消息框

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

Private Sub Application_Startup()

Dim MItem As MailItem
Set MItem = Application.CreateItem(olMailItem)
MItem.Subject = "Test Alert"
MItem.To = "email@abc.com"
MItem.DeferredDeliveryTime = DateAdd("n", 1, Now) 'n = minute, h=hour
MItem.Send


End Sub

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

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

Answer 1

这是一些我使用的代码；

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

前面的代码带给我们一个消息框，说明是否可以将其删除，但可以使用消息框和IF语句

例如；

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

或者如果没有消息框，则使用找到的IF之类的东西，依此类推...

希望这会有所帮助

Answer 2

主要错误是滥用On Error Resume Next。错误会被绕过，而不是固定的。

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

如果“已发送”文件夹中的项目过多，则“找不到”结果将变慢。

蛮力方式的一个可能选择是Restrict到特定项目，而不是使用If语句。

Outlook 365 VBA-搜索带有今天日期和特定主题的已发送邮件。如果找不到，请发送电子邮件

2 个答案: