vba - 通过关闭提醒来触发 Outlook 定期电子邮件

Question

我正在尝试在 Outlook 提醒被解除后发送电子邮件。

一旦提醒弹出，代码就会发送一封电子邮件。该代码基于https://www.extendoffice.com/documents/outlook/1567-outlook-send-schedule-recurring-email.html。

Private Sub Application_Reminder(ByVal Item As Object)
    
    'Updated by Extendoffice 20200522
    Dim xMailItem As MailItem
    Dim xItemDoc As Word.Document
    Dim xNewDoc As Word.Document
    Dim xFldPath As String
    Dim CurrentDATE
    CurrentDATE = Format(Date, "ddmmmyy")
    Dim Att As Attachment
    Dim tmpFolder
    Dim filePath As String
    
    On Error Resume Next
    If Item.Class <> OlObjectClass.olAppointment Then Exit Sub
    If Item.Categories <> "Send Schedule Recurring Email" Then Exit Sub
    Set xMailItem = Outlook.Application.CreateItem(olMailItem)
    Set xItemDoc = Item.GetInspector.WordEditor
    xFldPath = CStr(Environ("USERPROFILE"))
    xFldPath = xFldPath & "\MyReminder"
    If Dir(xFldPath, vbDirectory) = "" Then
        MkDir xFldPath
    End If
    xFldPath = xFldPath & "\AppointmentBody.xml"
    xItemDoc.SaveAs2 xFldPath, wdFormatXMLDocument ' wdFormatXML
    Set xNewDoc = xMailItem.GetInspector.WordEditor
    VBA.DoEvents
    xNewDoc.Application.Selection.HomeKey
    xNewDoc.Activate
    xNewDoc.Application.Selection.InsertFile FileName:=xFldPath, Attachment:=False
    
    tmpFolder = Environ("USERPROFILE")
    For Each Att In Item.Attachments
    filePath = tmpFolder & "\" & Att.FileName
    Att.SaveAsFile (filePath)
    xMailItem.Attachments.Add filePath
    Kill filePath
    Next Att

    With xMailItem
        .To = Item.Location
        .Recipients.ResolveAll
        .Subject = Item.Subject & " for " & CurrentDATE
        .Send
    End With
    Set xMailItem = Nothing
    VBA.Kill xFldPath
    
End Sub

标签： vbaemailoutlookoutlook-2010reminders