Question

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

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

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中。我收到一条消息，内容为

无效的外部程序。

Answer 1

最后，我做了些调情，发现了一些有用的技巧，终于解决了以下问题：

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

我希望它将对您有帮助

Answer 2

Umberto的回答是正确的，但是有一个小错误。

Item.GetInspector() -> Item.GetInspector

Item.GetInspector.WordEditor.Range.Copy
MItem.GetInspector.WordEditor.Range.Paste

一些使我了解此问题的消息源：

定期定期发送电子邮件

2 个答案: