Word 2010将电子邮件正文复制到Word文档中

错误似乎与你的循环有关，在任何情况下都显得多余。将代码更改为LateBinding，以下似乎正常工作

The error seems to relate to your loop, which in any case appears superfluous. Changing the code to LateBinding, the following appears to work OK

选项显式



Sub CheckEMail（）

    On Error GoTo ErrorHandler

    Dim appOutlook As Object

    Dim ins As Object

    Dim msg As Object

    Dim strMessage As String

    Dim doc As Object

    Dim prps As Object

    Dim emailOpen As Boolean

   设置doc = Documents.Add

   设置prps = doc.CustomDocumentProperties

    '确定Outlook是否正在运行

   设置appOutlook = GetObject（，" Outlook.Application"）

    '确定是否在Inspector中打开Outlook项目

   设置ins = appOutlook.ActiveInspector

   如果ins is Nothing Then

        strMessage ="没有打开电子邮件进行检查"

        MsgBox strMessage

        ActiveDocument.Close（False）

        GoTo ErrorHandlerExit

   否则

        MsgBox"当前项目类：" &安培; ins.CurrentItem.Class

   结束如果是
    '确定当前打开的Outlook项目类别
    emailOpen = False



    Application.ScreenUpdating = False

    'Do Until ins<> appOutlook.ActiveInspector

       如果ins.CurrentItem.Class<> 43并且emailOpen = False然后是
            '当前商品不是邮件商品¥b $ b            strMessage ="没有打开电子邮件进行检查"

            MsgBox strMessage

            ActiveDocument.Close（False）

            GoTo ErrorHandlerExit

        ElseIf ins.CurrentItem.Class = 43然后

            '当前项目是邮件项目;将数据保存到doc属性

            emailOpen = True

           设置msg = ins.CurrentItem

            Application.Selection.TypeText Text：= msg.Body

            Application.Selection.TypeText Text：= Chr

Option Explicit

Sub CheckEMail()
    On Error GoTo ErrorHandler
    Dim appOutlook As Object
    Dim ins As Object
    Dim msg As Object
    Dim strMessage As String
    Dim doc As Object
    Dim prps As Object
    Dim emailOpen As Boolean
    Set doc = Documents.Add
    Set prps = doc.CustomDocumentProperties
    'Determine whether Outlook is running
    Set appOutlook = GetObject(, "Outlook.Application")
    'Determine whether an Outlook item is open in an Inspector
    Set ins = appOutlook.ActiveInspector
    If ins Is Nothing Then
        strMessage = "There is no email open to check"
        MsgBox strMessage
        ActiveDocument.Close (False)
        GoTo ErrorHandlerExit
    Else
        MsgBox "Current item class: " & ins.CurrentItem.Class
    End If
    'Determine class of currently open Outlook item
    emailOpen = False

    Application.ScreenUpdating = False
    'Do Until ins <> appOutlook.ActiveInspector
        If ins.CurrentItem.Class <> 43 And emailOpen = False Then
            'Current item is not a mail item
            strMessage = "There is no email open to check"
            MsgBox strMessage
            ActiveDocument.Close (False)
            GoTo ErrorHandlerExit
        ElseIf ins.CurrentItem.Class = 43 Then
            'Current item is a mail item; save data to doc properties
            emailOpen = True
            Set msg = ins.CurrentItem
            Application.Selection.TypeText Text:=msg.Body
            Application.Selection.TypeText Text:=Chr

（13）+ Chr

（13）

 &nbsp ;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;结束如果

        msg.Close 1

       设置ins = appOutlook.ActiveInspector

       如果ins is Nothing Then

            CheckWordDoc是
           退出Sub¥
       否则为
           设置msg = ins.CurrentItem

       结束如果是
    '循环



    Application.ScreenUpdating = True

ErrorHandlerExit：

   退出Sub¥


ErrorHandler：

   如果Err.Number = 429则为
        strMessage =" Outlook未运行;无法导入邮件"

        MsgBox strMessage

        ActiveDocument.Close（False）

        GoTo ErrorHandlerExit

    ElseIf Err.Number = 91然后

        strMessage ="没有邮件消息被打开;无法导入邮件"

        MsgBox strMessage

        ActiveDocument.Close（False）

        GoTo ErrorHandlerExit

   否则

        MsgBox"错误号：" &安培; Err.Number&英寸;说明：" &安培;错误描述

   结束如果是
   恢复ErrorHandlerExit

结束子

(13)
        End If
        msg.Close 1
        Set ins = appOutlook.ActiveInspector
        If ins Is Nothing Then
            CheckWordDoc
            Exit Sub
        Else
            Set msg = ins.CurrentItem
        End If
    'Loop

    Application.ScreenUpdating = True
ErrorHandlerExit:
    Exit Sub

ErrorHandler:
    If Err.Number = 429 Then
        strMessage = "Outlook is not running; can't import mail"
        MsgBox strMessage
        ActiveDocument.Close (False)
        GoTo ErrorHandlerExit
    ElseIf Err.Number = 91 Then
        strMessage = "No mail message is open; can't import mail"
        MsgBox strMessage
        ActiveDocument.Close (False)
        GoTo ErrorHandlerExit
    Else
        MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
    End If
    Resume ErrorHandlerExit
End Sub

但是如果您只是抓取邮件正文，则无需打开邮件，因此ActiveInspector不相关。除非您可以告诉宏要处理哪些消息（或多个消息），否则最好从Outlook运行该过程。
以下内容将所选邮件的正文复制到新的Word文档：

However if you are simply grabbing the message body, there is no need to open the message and thus the ActiveInspector is not relevant. Unless you can tell the macro which message (or messages) to process, it would be better to run the process from Outlook. The following will copy the body of the selected message to a new Word document:

选项显式

Sub CopyToWord（）

Dim wdApp As Object

Dim wdDoc As Object

Dim oRng As Object

Dim bStarted As Boolean

Dim olItem As MailItem

如果Application.ActiveExplorer.Selection.Count = 0则为
    MsgBox"未选择任何项目！"，vbCritical，"错误"

   退出Sub¥
结束如果

On Error Resume Next

设置wdApp = GetObject（，"Word.Application"）

如果错误则为
   设置wdApp = CreateObject（" Word.Application"）

    bStarted = True

结束如果

On Error GoTo 0

For Each olItem In Application.ActiveExplorer.Selection

&NBSP;&NBSP;&NBSP;设置wdDoc = wdApp.Documents.Add

    wdDoc.Range.Text = olItem.Body

下一个olItem

设置wdDoc =无什么b $ b设置wdApp = Nothing

设置olItem = Nothing

End Sub

Sub CopyToWord()
Dim wdApp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim bStarted As Boolean
Dim olItem As MailItem
If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
End If
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
    Set wdApp = CreateObject("Word.Application")
    bStarted = True
End If
On Error GoTo 0
For Each olItem In Application.ActiveExplorer.Selection
    Set wdDoc = wdApp.Documents.Add
    wdDoc.Range.Text = olItem.Body
Next olItem
Set wdDoc = Nothing
Set wdApp = Nothing
Set olItem = Nothing
End Sub