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

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

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

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

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

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

---

您必须稍微修改您的

CreateAppointment

sub，
但在发送邮件之前，请使用变量存储邮件内容，然后将其传递给您的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

Public Sub Fooo（）
将项目设置为Outlook.items
将项目变暗为对象
将ITM内容设置为字符串
Set items=Application.ActiveExplorer.CurrentFolder.items
Set Item=items.Add（“IPM.Note.My-Template-Mail”）
Item.SentonBehalfName=”foo@bar.com"
项目.显示
“转到邮件发送”时出错
做
ItmContent=Item.Body'或您在CreateAppointment中使用的其他属性
多芬特
循环直到项目为空
错误转到0
多芬特
结束后：
'Debug.Print ItmContent
创建约会ItmContent
出口接头
邮寄：
如果错误号为2147221238，则
调试.打印错误编号和vbCrLf及错误说明
出口接头
其他的
结束后恢复
如果结束
端接头

等待Items.ItemAdd事件在Sent Items文件夹中触发，然后创建新约会

当Item.Sent=False时，在循环内部添加

DoEvents

。您可以为

CreateAppointment

添加代码吗？添加

DoEvents

可以防止Outlook冻结。我认为添加

CreateAppointment

会导致问题中的代码太多，与问题无关。我再次遇到同样的错误：运行时错误“-2147221238（8004010a）“：元素已移动….@foobarbaz:在哪一行？随机

While.Sent=False

或

ItmContent=.Body

这将永远不会起作用-消息提交后，唯一允许的操作是释放对它的引用。Sent属性永远不会变为true-Sent Items文件夹中的邮件与您显示的邮件在物理上不同。是的，通过错误处理，它现在可以工作了，谢谢！：-）你对哪一部分有问题？

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