在当前电子邮件正文中打开.rtf附件并粘贴内容

Question

我们有一个Access数据库，该数据库正在使用该SendObject方法将报告导出为电子邮件的附件。

我需要做的是打开附件，复制文本（使用格式），然后将其粘贴到生成的电子邮件的正文中并删除文件。

我已经获得了剥离附件并打开它的代码，但是我不确定如何复制Word文档中的所有内容并将其粘贴回原始电子邮件中。

任何帮助将不胜感激！如果有更简单的方法，请告诉我。

Sub olAttachmentStrip()
  Dim strFilename As String
  Dim strPath As String
  Dim olItem As Outlook.MailItem
  Dim olAtmt As Outlook.Attachments
  Dim olInspector As Outlook.Inspector
  Dim appWord As Word.Application
  Dim docWord As Word.Document

  strPath = "C:\temp\"

  Set olInspector = Application.ActiveInspector
  If Not TypeName(olInspector) = "Nothing" Then
    If TypeName(olInspector.CurrentItem) = "MailItem" Then
        Set olItem = olInspector.CurrentItem
        Set olAtmt = olItem.Attachments
            olAtmt.Item(1).SaveAsFile strPath & olAtmt.Item(1).DisplayName
            strFilename = strPath & olAtmt.Item(1).DisplayName
            'olAtmt.Item(1).Delete
    Else
    MsgBox "Something went horribly wrong."
    End If
  End If

  Set appWord = CreateObject("Word.Application")
  appWord.Visible = False 
  Set docWord = appWord.Documents.Open(strFilename)
  Stop  '<==  This is where I'm stuck!
  Set docWord = Nothing
  Set appWord = Nothing
End Sub

Answer 1

由于您已经具有提取附件的代码。下一步是简单地打开文件，复制完整的文本并将其粘贴到当前电子邮件中。

试试这个（尝试和测试）

Option Explicit

Sub Sample()
    Dim doc As Object, sel As Object
    Dim oWord As Object, oDoc As Object, wRng As Object


    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oWord = GetObject(, "Word.Application")

    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oWord = CreateObject("Word.Application")
    End If
    Err.Clear
    On Error GoTo 0

    '~~> Open the Attachement
    Set oDoc = oWord.Documents.Open(FileName:="C:\MyDocument.rtf", ConfirmConversions:=False, _
        ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=0, XMLTransform:="", _
        Encoding:=1200)

    '~~> Get the comeplete text and copy it
    Set wRng = oDoc.Range
    wRng.Copy

    '~~> Close word Doc
    oDoc.Close

    '~~> Paste it in active email
    Set doc = ActiveInspector.WordEditor
    Set sel = doc.Application.Selection
    sel.Paste

    '~~> Clean up
    Set wRng = Nothing: Set oDoc = Nothing: Set oWord = Nothing
End Sub