如何在 Outlook VBA 中等待电子邮件发送并关闭 window？

Question

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

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

如何等待发送电子邮件并关闭其 window？

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

runtime error '-2147221238 (8004010a)': element moved....

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

你必须稍微修改一下你的 CreateAppointment 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")

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

Answer 2

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

如何在 Outlook VBA 中等待电子邮件发送并关闭 window？

How to wait until e-mail is sent and window is closed in Outlook VBA?

email

outlook

vba

outlook-2010