VBA复制word内容到outlook报错："word has encountered a problem"的解决方案

将富文本内容复制到outlook中时经常会遇到报错：word has encountered a problem。尝试过N多种方法均无法解决。

    ' 打开RTF文件
    Set wdDoc = wdApp.Documents.Open("example.docx")
    ' 复制RTF内容
    wdDoc.Content.Copy
    Application.Wait (Now + TimeValue("0:00:03"))
    olMail.Display
    ' 粘贴到邮件正文(概率性报错：word has encountered a problem)
    olMail.GetInspector.WordEditor.Content.Paste

最后发现，复制之前点击下outlook的新建邮件的对话框可以避免这个报错。下面是解决方法：

Function PasteToMail(ByRef wdDoc As Object, ByRef olMail As Object)
    Dim i As Integer
    Dim draftFlag As Boolean
    

    Debug.Print "正在粘贴邮件正文......"
    
    ' 重试五次
    For i = 0 To 5
        ' 执行粘贴
        On Error Resume Next
        If i > 0 Then Debug.Print "正在重试" & i
        ' 复制RTF内容
'        olMail.BodyFormat = olFormatRichText
        ' 粘贴到邮件正文,复制粘贴之前先点击下新建邮件对话框
        ClickNewMailWindowCenter
        wdDoc.Content.Copy
'        Application.Wait (Now + TimeValue("0:00:05"))
        olMail.GetInspector.WordEditor.Range(0).PasteAndFormat Type:=wdFormatOriginalFormatting ' 使用原始格式
        Application.Wait (Now + TimeValue("0:00:03"))
        On Error GoTo 0
        If Len(olMail.GetInspector.WordEditor.Range.text) > 10 Then
            draftFlag = True
            Debug.Print "粘贴邮件正文成功！"
            Exit For
        End If
    Next
    If Not draftFlag Then
        Err.Raise Number:=513, Source:="Tool Error Tips", Description:="粘贴邮件正文内容失败！"
    End If
End Function

下面是点击outlook邮件对话框代码

#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, ByRef lpRect As rect) As Long
    Private Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
    Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
    Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
    Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

Private Type rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Const MOUSEEVENTF_LEFTDOWN = &H2
Const MOUSEEVENTF_LEFTUP = &H4
Const SW_RESTORE = 9

Sub ClickNewMailWindowCenter()
    Dim hWnd As LongPtr
    Dim rect As rect
    Dim centerX As Long, centerY As Long
    
    ' 查找Outlook新建邮件窗口的句柄
    ' 注意：类名可能是 "rctrl_renwnd32"，标题可能包含“邮件 - Microsoft Outlook”
    hWnd = FindWindow("rctrl_renwnd32", vbNullString) ' 可尝试使用 Null 标题匹配任意标题

    If hWnd = 0 Then
        'MsgBox "未找到新建邮件窗口。请先打开新邮件窗口。"
        Exit Sub
    End If

    ' 获取窗口位置
    Call GetWindowRect(hWnd, rect)

    ' 计算中心点
    centerX = (rect.Left + rect.Right) \ 2
    centerY = (rect.Top + rect.Bottom) \ 2

    ' 将窗口恢复到前台并置顶
    Call ShowWindow(hWnd, SW_RESTORE)
    Call BringWindowToTop(hWnd)

    ' 延迟一下确保窗口准备好（可选）
    Application.Wait Now + TimeValue("00:00:01")

    ' 移动光标并点击
    SetCursorPos centerX, centerY
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0

'    MsgBox "已点击新建邮件窗口的正中间位置。"
End Sub