Word 2010将电子邮件正文复制到Word文档中 [英] Word 2010 copy Email Body into Word document

问题描述

在Word 2003和2013中，我创建了一个Word宏，它将打开的电子邮件的内容复制到空白的Word文档中。但是，由于某种原因，相同的宏不会在Word 2010中运行。违规行（粗体/下划线）会生成错误消息，
读取，

In Word 2003 and 2013 I have created a Word macro which copies the content of an open email into a blank Word document. However, for some reason, the same macro does not run in Word 2010. The offending line (bold/underlined) produces an error message which reads,

"错误号287：描述：应用程序定义或对象定义的错误。"

"Error No 287: Description: Application-defined or Object-defined error."

调试时，我可以看到主题字段已被"msg"捕获。变量但msg.Body保持空白。

When debugging, I can see the Subject field has been captured by the "msg" variable but msg.Body remains blank.

有人能指出我在2010年导致此错误的正确方向，但不是其他版本的Word吗？

Could someone point me in the right direction as to what's causing this error in 2010 but not other versions of Word?

非常感谢您的帮助。

Martin Mullen。

Martin Mullen.

我的代码如下： -

My code is as follows:-

Sub CheckEmail（）

Sub CheckEmail()

On Error GoTo ErrorHandler  

On Error GoTo ErrorHandler  

Dim appOutlook As Outlook.Application

Dim appOutlook As Outlook.Application

   Dins ins As Outlook.Inspector

   Dim ins As Outlook.Inspector

   Dim msg As Outlook.MailItem

   Dim msg As Outlook.MailItem

   Dim strMessage As String

   Dim strMessage As String

   Dim doc As Word.Document

   Dim doc As Word.Document

   Dim prps As Object

   Dim prps As Object

   Dim emailOpen As Boolean

   Dim emailOpen As Boolean

  设置doc = Documents.Add

   Set doc = Documents.Add

  设置prps = doc.CustomDocumentProperties

   Set prps = doc.CustomDocumentProperties

   '确定Outlook是否正在运行

   'Determine whether Outlook is running

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

   Set appOutlook = GetObject(, "Outlook.Application")

   '确定Outlook项目是否在检查器中打开

   'Determine whether an Outlook item is open in an Inspector

  设置ins = appOutlook.ActiveInspector

   Set ins = appOutlook.ActiveInspector

  如果ins is Nothing Then

   If ins Is Nothing Then

      strMessage ="没有电子邮件可以查看"

      strMessage = "There is no email open to check"

      MsgBox strMessage

      MsgBox strMessage

      ActiveDocument.Close（False）

      ActiveDocument.Close (False)

      GoTo ErrorHandlerExit

      GoTo ErrorHandlerExit

  否则

   Else

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

      Debug.Print "Current item class: " & ins.CurrentItem.Class

  结束如果

   End If

   '确定当前打开的Outlook项目的类别

   'Determine class of currently open Outlook item

   emailOpen = False

  

    Application.ScreenUpdating = False

   emailOpen = False
  
    Application.ScreenUpdating = False

   Do Until ins<> appOutlook.ActiveInspector

   Do Until ins <> appOutlook.ActiveInspector

       如果ins.CurrentItem.Class<> olMail和emailOpen = False然后

        If ins.CurrentItem.Class <> olMail And emailOpen = False Then

            '当前商品不是邮件商品

            'Current item is not a mail item

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

            strMessage = "There is no email open to check"

            MsgBox strMessage

            MsgBox strMessage

            ActiveDocument.Close（错误）

            ActiveDocument.Close (False)

            GoTo ErrorHandlerExit

            GoTo ErrorHandlerExit

        ElseIf ins.CurrentItem.Class = olMail Then

        ElseIf ins.CurrentItem.Class = olMail Then

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

            'Current item is a mail item; save data to doc properties

            emailOpen = True

            emailOpen = True

           设置msg = ins.CurrentItem

            Set msg = ins.CurrentItem

           
Application.Selection.TypeText Text：= msg.Body

            Application.Selection.TypeText Text:=msg.Body

  ;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP; Application.Selection.TypeText Text：= Chr $（13）+ Chr $（13）

            Application.Selection.TypeText Text:=Chr$(13) + Chr$(13)

       结束如果

        End If

        msg.Close（olDiscard）

        msg.Close (olDiscard)

       设置ins = appOutlook.ActiveInspector

        Set ins = appOutlook.ActiveInspector

       如果ins is Nothing Then

        If ins Is Nothing Then

            CheckWordDoc

            CheckWordDoc

           退出子

            Exit Sub

       否则

        Else

           设置msg = ins.CurrentItem

            Set msg = ins.CurrentItem

       结束如果

        End If

   循环

  

Application.ScreenUpdating = True

    Loop
  
Application.ScreenUpdating = True

ErrorHandlerExit：

ErrorHandlerExit:

   退出子

    Exit Sub

 

错误处理程序：

  如果Err.Number = 429那么

   If Err.Number = 429 Then

     strMessage =" Outlook未运行;无法导入邮件"

     strMessage = "Outlook is not running; can't import mail"

      MsgBox strMessage

      MsgBox strMessage

      ActiveDocument.Close（False）

      ActiveDocument.Close (False)

      GoTo ErrorHandlerExit

      GoTo ErrorHandlerExit

   ElseIf Err.Number = 91然后

   ElseIf Err.Number = 91 Then

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

      strMessage = "No mail message is open; can't import mail"

      MsgBox strMessage

      MsgBox strMessage

      ActiveDocument.Close（False）

      ActiveDocument.Close (False)

      GoTo ErrorHandlerExit

      GoTo ErrorHandlerExit

  否则

   Else

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

      MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description

  结束如果

   End If

  恢复ErrorHandlerExit

   Resume ErrorHandlerExit

 

End Sub

推荐答案

错误似乎与你的循环有关，在任何情况下都显得多余。将代码更改为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;结束如果

        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

这篇关于Word 2010将电子邮件正文复制到Word文档中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！