Question

我的VBA代码会打开一个电子邮件模板，并应在编辑和发送电子邮件后将电子邮件内容复制到约会中。

问题是在发送电子邮件之前会打开约会，未经编辑的电子邮件内容会插入到约会中。（如果我删除了while循环）

我如何等待发送电子邮件并关闭其窗口？

错误：Outlook冻结或显示错误：

运行时错误'-2147221238（8004010a）'：元素已移动....

Public Sub Fooo()
Dim items As Outlook.items
Dim Item As Object

Set items = Application.ActiveExplorer.CurrentFolder.items

Set Item = items.Add("IPM.Note.My Template Mail")
Item.SentOnBehalfOfName = "foo@bar.com"
Item.Display

While Item.Sent = False
Wend

CreateAppointment MyMail:=Item

End Sub

Answer 1

等待Items.ItemAdd事件在“已发送邮件”文件夹上触发，然后才创建新约会。

Answer 2

你必须修改你的CreateAppointment子，。但在发送邮件之前使用变量来存储邮件内容，然后将其传递给您的邮件！

Public Sub Fooo()
Dim items As Outlook.items
Dim Item As Object
Dim ItmContent As String

Set items = Application.ActiveExplorer.CurrentFolder.items

Set Item = items.Add("IPM.Note.My Template Mail")

With Item
    .SentOnBehalfOfName = "foo@bar.com"
    .Display True

    Do
        ItmContent = .Body 'Or other property that you use in CreateAppointment
        DoEvents
    Loop Until Item Is Nothing
End With 'Item

CreateAppointment ItmContent

End Sub

带错误处理的工作解决方案：

Public Sub Fooo()
Dim items As Outlook.items
Dim Item As Object
Dim ItmContent As String

Set items = Application.ActiveExplorer.CurrentFolder.items

Set Item = items.Add("IPM.Note.My Template Mail")

Item.SentOnBehalfOfName = "foo@bar.com"
Item.Display

On Error GoTo MailSent
    Do
        ItmContent = Item.Body 'Or other property that you use in CreateAppointment
        DoEvents
    Loop Until Item Is Nothing
On Error GoTo 0


DoEvents
AfterSend:
    'Debug.Print ItmContent
    CreateAppointment ItmContent
    Exit Sub
MailSent:
    If Err.Number <> -2147221238 Then
        Debug.Print Err.Number & vbCrLf & Err.Description
        Exit Sub
    Else
        Resume AfterSend
    End If
End Sub

如何等到发送电子邮件并在Outlook VBA中关闭窗口？

2 个答案: