Excel VBA-使用word编辑器冻结outlook

我希望在一个问题上得到一些帮助

我运行一个excel宏，它发送两封带有不同附件的电子邮件，电子邮件正文中还有一个复制范围

对于复制的范围，我使用word作为getinspector。第一封邮件可以正常工作，但当它发送到第二封邮件时，我的outlook就会冻结在第二行

Set wordDoc = MyItem.GetInspector.WordEditor

我的Outlook完全冻结，它没有说“没有响应”或变为白色。我只是无法单击任何内容，也无法关闭它，除非我使用任务管理器

这是上述代码第二次在冻结处引用

以下是完整的代码：

Dim myOlApp As Outlook.Application
Dim MyItem As Outlook.MailItem
Dim wordDoc As Word.Document
Dim rngp As Object
Dim shp As Object
DoEvents

Workbooks.Open FileName:="######" & Format(Date - 7, "DD-MM-YY") & ".xlsx", ReadOnly:=True

Workbooks("####" & Format(Date - 7, "DD-MM-YY") & ".xlsx").Activate

Set rng = Nothing
On Error Resume Next
Set rng = Workbooks("###" & Format(Date - 7, "DD-MM-YY") & ".xlsx").Sheets("Queue Overview").Range("E1:H11")
rng.Copy

Set myOlApp = CreateObject("Outlook.Application")
Set MyItem = myOlApp.CreateItemFromTemplate("#####")
On Error GoTo 0

Set wordDoc = MyItem.GetInspector.WordEditor

With MyItem
    .Display
End With
    Signature = MyItem.HTMLBody


With MyItem
    .SendUsingAccount = myOlApp.Session.Accounts.Item(3)
    .To = ""
    .Subject = ""
    .Attachments.Add "#####" & Format(Date - 7, "DD-MM-YY") & ".xlsx"
    wordDoc.Range.PasteAndFormat (wdChartPicture)
    wordDoc.Range.InsertBefore "Good Afternoon" & vbNewLine & vbNewLine & "Please find attached"
    wordDoc.Range.InsertAfter vbNewLine & vbNewLine & "As I'm sending data"
    .HTMLBody = .HTMLBody & vbNewLine & vbNewLine & "Regards" & Signature
    For Each shp In wordDoc.InlineShapes
        shp.ScaleHeight = 100
        shp.ScaleWidth = 100
    Next
    .Send
 End With


Set rng = Nothing
Set MyItem = Nothing
Set myOlApp = Nothing
Set wordDoc = Nothing

Workbooks("###" & Format(Date - 7, "DD-MM-YY") & ".xlsx").Close savechanges:=True

Application.Wait (Now + TimeValue("0:00:15"))

Workbooks.Open FileName:="####" & Format(Date - 7, "DD-MM-YY") & ".xlsx", ReadOnly:=True

Workbooks(Format(Date - 7, "DD-MM-YY") & ".xlsx").Activate

Set rng = Nothing
On Error Resume Next
Set rng = Workbooks(Format(Date - 7, "DD-MM-YY") & ".xlsx").Sheets("Queue Overview").Range("E1:H11")
rng.Copy

Set myOlApp = CreateObject("Outlook.Application")
Set MyItem = myOlApp.CreateItemFromTemplate("####")
On Error GoTo 0

Set wordDoc = MyItem.GetInspector.WordEditor

With MyItem
    .Display
End With
    Signature = MyItem.HTMLBody


With MyItem
    .SendUsingAccount = myOlApp.Session.Accounts.Item(3)
    .To = ""
    .Subject = ""
    .Attachments.Add "#####" & Format(Date - 7, "DD-MM-YY") & ".7z"
    wordDoc.Range.PasteAndFormat (wdChartPicture)
    wordDoc.Range.InsertBefore "Good Afternoon" & vbNewLine & vbNewLine & "Please find attached"
    wordDoc.Range.InsertAfter vbNewLine & vbNewLine & "As I'm sending data"
    .HTMLBody = .HTMLBody & vbNewLine & vbNewLine & "Regards" & Signature
    For Each shp In wordDoc.InlineShapes
        shp.ScaleHeight = 100
        shp.ScaleWidth = 100
    Next
    .Send
 End With

Set rng = Nothing
Set MyItem = Nothing
Set myOlApp = Nothing

Workbooks(Format(Date - 7, "DD-MM-YY") & ".xlsx").Close savechanges:=True

---

您是否尝试过删除所有“下一步继续出错”以查看出现的错误？同样的情况也会发生。唯一出现的错误消息是当我关闭outlook时，它显示为“自动化错误”