Sending word document data as Outlook message

The below code is used to send word document data (basically combination of images, text and graphics) in the outlook message body, this is particularly needed to send VOC survey to many customers like each mail drafted separately with rich text/HTML message content..


Modul1: Create multiple outlook e-mails (html/rich text)
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
    
Dim i


For i = 2 To ShtX.Cells(ShtX.Rows.Count, 1).End(xlUp).Row
    
    Call CreateNewWordDoc(Trim(ShtX.Cells(i, 2)))
    
    Set wd = CreateObject("Word.Application")
    
    wd.Visible = True
    
    Set doc = wd.Documents.Open(Filename:="D:\Automation Works\VOC\VOC Message.doc", ReadOnly:=True)
    Set itm = doc.MailEnvelope.Item


    With itm
        .SentOnBehalfOfName = "pss chennai"
        .To = Trim(ShtX.Cells(i, 1))
        .Subject = "PSS - VOC Survey (Dec'11) - Reminder"
        .Attachments.Add "D:\Automation Works\VOC\ESS VOC Survey.xls"
        .Send
    End With
    
    doc.Close savechanges:=False
    wd.Quit
  
    Set doc = Nothing
    Set itm = Nothing
    Set wd = Nothing
    
Next i


End Sub


Modul2: Create multiple messages, addressed to each receipient
Sub CreateNewWordDoc(RecptName As String)
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim i As Integer
    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
    
    'Set wrdDoc = wrdApp.Documents.Add
    ' or
     Set wrdDoc = wrdApp.Documents.Open("D:\Automation Works\VOC\Greetings.doc")
        
    ' sample word operations
    With wrdDoc
            .Content.InsertBefore "Hello " & RecptName & "," & vbNewLine
            .Content.InsertParagraphBefore
        
        
        If Dir("D:\Automation Works\VOC\VOC Message.doc") <> "" Then
            Kill "D:\Automation Works\VOC\VOC Message.doc"
        End If
        
        .SaveAs ("D:\Automation Works\VOC\VOC Message.doc")
        .Close
    End With
    
    wrdApp.Quit
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    
End Sub