Creating Word document from Excel - unable to save with password

[sharky12345]

I'm using this to create a Word document from Excel;

Sub CopyToWord()
      Dim objWord As Object
      Dim objDoc As Object

      'Hide background file open
10    Application.ScreenUpdating = False

      'Open Word if not already open
20    Set objWord = CreateObject("Word.Application")
30    Set objDoc = objWord.documents.Add(ThisWorkbook.path & "\Return Review Form.doc") 'objWord.Documents.Add

      'Copy data across
40    objDoc.Tables(1).Cell(1, 3).Range.Text = Sheets("Return").Range("C3").Value
50    objDoc.Tables(1).Cell(2, 3).Range.Text = Sheets("Return").Range("C4").Value
60    objDoc.Tables(1).Cell(3, 3).Range.Text = Sheets("Return").Range("C5").Value
70    objDoc.Tables(1).Cell(4, 3).Range.Text = Sheets("Return").Range("C6").Value
80    objDoc.Tables(1).Cell(5, 3).Range.Text = Sheets("Return").Range("C7").Value
90    objDoc.Tables(1).Cell(6, 3).Range.Text = Sheets("Return").Range("C8").Value
100   objDoc.Tables(1).Cell(7, 3).Range.Text = Sheets("Return").Range("C9").Value
110   objDoc.Tables(1).Cell(8, 3).Range.Text = Sheets("Return").Range("C50").Value
120   objDoc.Tables(1).Cell(9, 3).Range.Text = Sheets("Return").Range("C10").Value
130   objDoc.Tables(1).Cell(12, 2).Range.Text = Sheets("Return").Range("A13").Value
140   objDoc.Tables(1).Cell(15, 2).Range.Text = Sheets("Return").Range("A16").Value
150   objDoc.Tables(1).Cell(18, 2).Range.Text = Sheets("Return").Range("A19").Value
160   objDoc.Tables(1).Cell(21, 2).Range.Text = Sheets("Return").Range("A22").Value
170   objDoc.Tables(1).Cell(24, 2).Range.Text = Sheets("Return").Range("A25").Value
180   objDoc.Tables(1).Cell(27, 2).Range.Text = Sheets("Return").Range("A28").Value
190   objDoc.Tables(1).Cell(30, 2).Range.Text = Sheets("Return").Range("A31").Value
200   objDoc.Tables(1).Cell(33, 2).Range.Text = Sheets("Return").Range("A34").Value
210   objDoc.Tables(1).Cell(36, 2).Range.Text = Sheets("Return").Range("A37").Value
220   objDoc.Tables(1).Cell(39, 2).Range.Text = Sheets("Return").Range("A40").Value
230   objDoc.Tables(1).Cell(42, 2).Range.Text = Sheets("Return").Range("A43").Value
240   objDoc.Tables(1).Cell(47, 3).Range.Text = Sheets("Return").Range("C52").Value
250   objDoc.Tables(1).Cell(48, 3).Range.Text = Sheets("Return").Range("C47").Value

      'Protect document
260  ActiveDocument.Protect Password:="hh12345", NoReset:=False, Type:= _
       wdAllowOnlyFormFields, UseIRM:=False, EnforceStyleLock:=False

      'Save file with Survey No
270   If Sheets("Return").Range("C4").Value <> "NIL" Then
280   objDoc.SaveAs ThisWorkbook.path & "\Return - Survey No " & ThisWorkbook.Sheets("Return").Range("C4").Value & ".doc"
290   objDoc.Close
300   Exit Sub
310   End If

      'Save file with HHY No
320   If Sheets("Return").Range("C5").Value <> "NIL" Then
330   objDoc.SaveAs ThisWorkbook.path & "\Return - HHY No " & ThisWorkbook.Sheets("Return").Range("C5").Value & ".doc"
340   objDoc.Close
350   Exit Sub
360   End If

      'Save file with OP Name - if blank save as URN
370   If Not IsEmpty(Sheets("Return").Range("C6").Value) Then
380   objDoc.SaveAs ThisWorkbook.path & "\Return - OP " & ThisWorkbook.Sheets("Return").Range("C6").Value & ".doc"
390   objDoc.Close
400   Else
410   objDoc.SaveAs ThisWorkbook.path & "\Return - URN " & ThisWorkbook.Sheets("Return").Range("C52").Value & ".doc"
420   objDoc.Close
430   Exit Sub
440   End If

      'Tidy up
450   Set objDoc = Nothing
460   Set objWord = Nothing

      'Refresh screen
470   Application.ScreenUpdating = True
End Sub

Everything works fine, except it won't save as password protected with all fields locked, (users can delete text etc).

Can anyone assist?

 

[sharky12345]

*bump*

 

[sharky12345]

*bump*