Send Word Document As Body of Email

[Philosophaie]

I am trying to send a Word Document as the body of an email. This is what I have from another post. I tried to add a:

Dim outlook as Outlook.Application

but I also am confused about you can use the "doc", a Word.Document, in the same statement as an Outlook.MailItem?

Set itm = doc.MailEnvelope.Item

Sub SendDocAsMsg()
    Dim wd As Word.Application
    Dim doc As Word.Document
    Dim itm As Outlook.MailItem
    Dim ID As String
    Dim blnWeOpenedWord As Boolean
    
    Set wd = CreateObject("Word.Application")
    
    wd.Visible = True
    
    Set doc = wd.Documents.Open(Filename:="C:\Users\this\toEmail.doc", ReadOnly:=True)
    Set itm = doc.MailEnvelope.Item
    With itm
        .To = "[EMAIL="this@email"]this@email[/EMAIL].com"
        .Subject = "My Subject"
        .Send
    End With
    
    doc.Close
    wd.Quit
  
    Set doc = Nothing
    Set itm = Nothing
    Set wd = Nothing
    
End Sub

Add two references: Word and Outlook.

 

[daverunt]

Is this any use

http://www.howto-outlook.com/howto/senddocasmail.htm

 

[Philosophaie]

The getting the email and word document works. I can not figure out how to get the copied doc to display on the body of the email.

Sub SendDocAsMsg()
    Dim wd As Word.Application
    Dim doc As Word.Document
    Dim ID As String
    Dim blnWeOpenedWord As Boolean
    Dim oOutlookApp As Outlook.Application
    Dim oItem As Outlook.MailItem
    On Error Resume Next
    'Start Outlook if it isn't running
    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
    End If
    
    
    Set wd = CreateObject("Word.Application")
    
    wd.Visible = True
    
Set doc = wd.Documents.Open(Filename:="C:\path\file.doc", ReadOnly:=True)
'Copy the open document
Selection.WholeStory
Selection.Copy
Selection.End = True
   Set oItem = oOutlookApp.CreateItem(olMailItem)
    With oItem
        .To = "[EMAIL="this@email.com"]this@email.com[/EMAIL]"
        .Subject = "My Subject"
        .Body = Selection.Paste 'This does not work
        .Send
    End With
    
    doc.Close
    wd.Quit
    
    Set doc = Nothing
    Set oItem = Nothing
    Set oOutlookApp = Nothing
    Set wd = Nothing
End Sub

 

[John_w]

This works for me.

Sub SendDocAsMsg()
    Dim wd As Word.Application
    Dim doc As Word.Document
    Dim oOutlookApp As Outlook.Application
    Dim oItem As Outlook.MailItem
    
    On Error Resume Next
    'Start Outlook if it isn't running
    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    Set wd = CreateObject("Word.Application")
    
    wd.Visible = True
    
    Set doc = wd.Documents.Open(Filename:="C:\path\file.doc", ReadOnly:=True)
    
    'Copy the open document
    doc.Content.Select
    Word.Selection.Copy
    
    Set oItem = oOutlookApp.CreateItem(olMailItem)
    With oItem
        .To = "this@email.com"
        .Subject = "My Subject"
        .Body = Word.Selection
        .Send
    End With
    
    doc.Close
    wd.Quit
    
    Set doc = Nothing
    Set oItem = Nothing
    Set oOutlookApp = Nothing
    Set wd = Nothing
End Sub