在當前電子郵件正文中打開.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