时间戳

首页 > 解决方案 > 预定的定期电子邮件

vba - 预定的定期电子邮件

问题描述

下面的代码不会给出编译错误，但不会发送电子邮件。

目的是通过将它们链接到约会来发送定期电子邮件。

Private Sub Application_Reminder(ByVal Item As Object)
Dim xMailItem As MailItem
Dim xItemDoc As Word.Document
Dim xNewDoc As Word.Document
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
xItemDoc.Activate
xItemDoc.Application.Selection.WholeStory
xItemDoc.Application.Selection.Copy
With xMailItem
    .To = Item.Location
    .Subject = Item.Subject
    Set xNewDoc = .GetInspector.WordEditor
    xNewDoc.Activate
    xNewDoc.Application.Selection.HomeKey
    xNewDoc.Content.Paste
    .Send
End With
Set xMailItem = Nothing
End Sub

似乎问题出在 Item.Class 中。我收到一条消息说

无效的外部程序。

标签： vbaemailoutlook

解决方案

最后，我做了一点调情，发现了一些有用的提示，我最终解决了如下：

Dim WithEvents objReminders As Outlook.Reminders
Private Sub Application_Reminder(ByVal Item As Object)
Dim MItem As MailItem
Set MItem = Application.CreateItem(olMailItem)
If Item.MessageClass <> "IPM.Appointment" Then Exit Sub
If Item.Categories <> "Send Schedule Recurring Email" Then Exit Sub
MItem.To = Item.Location
MItem.CC = ""
MItem.BCC = ""
MItem.Subject = Item.Subject
MItem.BodyFormat = olFormatHTML
Item.GetInspector().WordEditor.Range.Copy
MItem.GetInspector().WordEditor.Range.Paste
MItem.Display
MItem.Send
Set MItem = Nothing
End Sub

Private Sub Application_Startup()
Set objReminders = Application.Reminders
End Sub
Private Sub objReminders_ReminderFire(ByVal ReminderOBject As Reminder)

If ReminderOBject.Item.Categories <> "Send Schedule Recurring Email" Then Exit Sub

ReminderOBject.Dismiss

End Sub

我希望它会有所帮助

推荐阅读