How do I use Word as an email template and merge to Outlook

Private Sub Send_Email_Click()

Dim sFile As String
Dim i As Integer
Dim itm As Object
Dim ID As String
Dim wd As Word.Application
Dim Doc As Word.Document
Dim objApp As Outlook.Application
Dim l_Msg As MailItem
Dim oReceipt As Outlook.Recipient

' check buletin selected for sending

If Nz(Me!sendEBS, "") = "" Then
    MsgBox "Please select a bulletin to send"
    Exit Sub
End If


'get email addresses record set

    Select Case Me!sTo
    
        Case Is = "Members"
            Set rs = CurrentDb.OpenRecordset("SELECT [EmailName] FROM [Contacts] WHERE [Contact_Type] = 'Member'", dbOpenSnapshot, dbSeeChanges)
        Case Is = "Prospects"
            Set rs = CurrentDb.OpenRecordset("SELECT [EmailName] FROM [Contacts] WHERE [Contact_Type] = 'Prospect'", dbOpenSnapshot, dbSeeChanges)
        Case Else
            MsgBox "Please select a recipient"
            Exit Sub
    End Select
    
'Are You Sure
If vbNo = MsgBox("Send [ " & Me!sendEBS & " ] To [ " & Me!sTo & " ], Are you sure?", vbYesNo) Then
   Exit Sub
End If

Msg = "Enter the subject to be used for each email message."    ' Set prompt.

tit = " Email Subject Input"    ' Set title.

' Display message, title

sSubject = InputBox(Msg, tit)
    
If Nz(sSubject, "") = "" Then
    MsgBox "You must supply an email subject"
    Set rs = Nothing
    Exit Sub
End If
    
sFile = EBS_DIR & Me!sendEBS
[b]
Set wd = CreateObject("Word.Application")

Set Doc = wd.Documents.Open(FileName:=sFile, ReadOnly:=True)
    Set itm = Doc.MailEnvelope.Item
    With itm
        .To = DEFAULT_EMAIL
        .Subject = sSubject
        .Save
        ID = .EntryID
    End With

'clear references
Doc.Close wdDoNotSaveChanges
wd.Quit False

Set itm = Nothing
Set Doc = Nothing
Set wd = Nothing
[/b]
' start email and get saved item
    Set objApp = CreateObject("Outlook.Application")

    Set l_Msg = objApp.GetNamespace("MAPI").GetItemFromID(ID)
    
    With l_Msg
    
        'Loop over recipients
        Do While Not rs.EOF
            Set oReceipt = .Recipients.Add(rs.Fields("EmailName"))
            oReceipt.Type = olBCC
            rs.MoveNext
        Loop
        
        rs.Close
        Set rs = Nothing
  
        ' add any attachments
        If (Me.editEBS.ListCount > 0) Then
            i = 0

           Do While i < Me.attEBS.ListCount
                .Attachments.Add (Me.attEBS.ItemData(i))
                i = i + 1
            Loop

        End If
        
        .Display
    End With


    'clear references
    
    Set oReceipt = Nothing
    Set l_Msg = Nothing
    Set objApp = Nothing
    
End Sub