Change from an email to a word document

[Pete H4H]

Hi,

I have a sheet I have been working on for a while that I have pretty much got to do what I need it to do more by luck than judgement sometimes.
what I need to do now is really causing me a problem.
When I enter data via a userform it produces an email with the appropriate data on it, what I need it to do now is produce a word document that I can password protect before I send as an attachment to the email instead of having the data in the email.

It is probably easy but I just cant get it to create a word document, any help would be appreciated.
this is what i use to create the email.

Dim objOL As Object
Dim objMail As Object
Dim sEmail As String
Dim sTo As String
Dim sEmailColumn As String
Dim sSubject As String
Dim sBody As String
Dim lDataRow As Long
Dim cl As Range


Sheets("Data").Visible = True
Sheets("Data").Select
'email address
sEmailColumn = "BT"
For Each cl In Selection.Resize(, 1)
'Generate required info
lDataRow = Cells(Rows.Count, 1).End(xlUp).Row


sTo = Worksheets("Sheet1").Range("L20")
sEmail = Worksheets("Data").Range(sEmailColumn & lDataRow)
sSubject = "Request for Attendance"
sBody = "Dear " & Worksheets("Data").Range("O" & lDataRow) & _
vbNewLine & vbNewLine & "We have a new event in your area" & _
vbNewLine & "Please have a look at see who we would have available to look after this for us" & _
vbNewLine & vbNewLine & "Event Name :" & Worksheets("Data").Range("D" & lDataRow) & _
vbNewLine & "Event Date :" & Worksheets("Data").Range("F" & lDataRow) & _
vbNewLine & "Event Address :" & Worksheets("Data").Range("L" & lDataRow) & " - " & Worksheets("Data").Range("BW" & lDataRow) & _
vbNewLine & "Type of Event :" & Worksheets("Data").Range("E" & lDataRow) & _
vbNewLine & "Time :" & Worksheets("Data").Range("BR" & lDataRow) & " - " & Worksheets("Data").Range("BS" & lDataRow) & _
vbNewLine & "How Many Volunteers :" & Worksheets("Data").Range("M" & lDataRow) & _
vbNewLine & "Additional Information :" & Worksheets("Data").Range("U" & lDataRow) & _
vbNewLine & "Contact Name : " & Worksheets("Data").Range("I" & lDataRow) & _
vbNewLine & "Contact Email : " & Worksheets("Data").Range("K" & lDataRow) & _
vbNewLine & "Contact Phone Number : " & Worksheets("Data").Range("J" & lDataRow) & _
vbNewLine & vbNewLine & "Thanks" & vbNewLine & _
vbNewLine & Worksheets("Sheet1").Range("L" & 22) & _
vbNewLine & vbNewLine & Worksheets("Sheet1").Range("L" & 23) & _
vbNewLine & Worksheets("Data").Range("AI" & 5) & _
Worksheets("Sheet1").Range("K" & 12) & _
vbNewLine & Worksheets("Data").Range("AI" & 6) & Worksheets("Sheet1").Range("L" & 24) & _
vbNewLine & Worksheets("Data").Range("AI" & 7)


On Error GoTo Cleanup
'Bind to Outlook
Set objOL = CreateObject("Outlook.Application")
'Create a new email and send it
Set objMail = objOL.CreateItem(0) '0=olmailitem
With objMail
.To = sEmail
.cc = sTo
.Subject = sSubject
.Body = sBody
.Display
End With
'End If
Next cl
Cleanup:
'Release all objects
Set objMail = Nothing
Set objOL = Nothing
On Error GoTo 0
End Sub