Sub Copy_Cells_To_Word_Document()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim OutlApp As Object
Dim IsCreated As Boolean
Dim IsCreated1 As Boolean
Dim attacheddoc As String
Dim char As Variant
Dim wdfile As String
On Error Resume Next
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(FileName:=Range("Data!B27").Value, ReadOnly:=True)
wdApp.Visible = True
If Err Then
MsgBox "Template form not found", vbExclamation
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
Set wdDoc = Nothing
Exit Sub
Else
Copy_Cell_To_Form_Field wdDoc, Range("sheet!D8").Value, "CWname"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!p8").Value, "CWtel"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!D9").Value, "CWunit"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!p9").Value, "CWemail"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!i12").Value, "SUfirstname"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!i13").Value, "SUsurname"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!i14").Value, "SUaddress"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!i15").Value, "SUdob"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!i16").Value, "SUnino"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!i17").Value, "HOref"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!i18").Value, "deadline"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!A33").Value, "reasons"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!a62").Value, "other"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!a73").Value, "addinfo"
Copy_Cell_To_Form_Field wdDoc, Range("sheet!u80").Value, "date"
ticks
'Copy_Checkbox wdDoc, TB3IP.CheckboxState, "TB3IP"
'If TB3IP.Value = Checked Then
'wdDoc.FormFields("TB3IP").CheckBox.Value = True
'Else: wdDoc.FormFields("TB3IP").CheckBox.Value = False
'End If
'If TB3IR.Value = True Then wdDoc.FormFields("TB3IR").CheckBox.Value = True
'If TB3RL.Value = True Then wdDoc.FormFields("TB3RL").CheckBox.Value = True
'If TB3WS.Value = True Then wdDoc.FormFields("TB3WS").CheckBox.Value = True
'If TB4SM.Value = True Then wdDoc.FormFields("TB4SM").CheckBox.Value = True
'If TB4E.Value = True Then wdDoc.FormFields("TB4E").CheckBox.Value = True
'If TB4EEA.Value = True Then wdDoc.FormFields("TB4EEA").CheckBox.Value = True
'If TB4A8.Value = True Then wdDoc.FormFields("TB4A8").CheckBox.Value = True
'If TB4SV.Value = True Then wdDoc.FormFields("TB4SV").CheckBox.Value = True
'If TB4F.Value = True Then wdDoc.FormFields("TB4F").CheckBox.Value = True
'If TB4NC.Value = True Then wdDoc.FormFields("TB4NC").CheckBox.Value = True
'If TB4CR.Value = True Then wdDoc.FormFields("TB4CR").CheckBox.Value = True
'If tb5dip.Value = True Then wdDoc.FormFields("tb5dip").CheckBox.Value = True
'If tb5disa.Value = True Then wdDoc.FormFields("tb5disa").CheckBox.Value = True
'If tb5ce.Value = True Then wdDoc.FormFields("tb5ce").CheckBox.Value = True
'If tb5tc.Value = True Then wdDoc.FormFields("tb5tc").CheckBox.Value = True
'If tb5cb.Value = True Then wdDoc.FormFields("tb5cb").CheckBox.Value = True
'If tb5bbsa.Value = True Then wdDoc.FormFields("tb5bbsa").CheckBox.Value = True
'If tb5pa.Value = True Then wdDoc.FormFields("tb5pa").CheckBox.Value = True
'If tb5ba.Value = True Then wdDoc.FormFields("tb5ba").CheckBox.Value = True
'If tb5ci.Value = True Then wdDoc.FormFields("tb5ci").CheckBox.Value = True
'If tb5tn.Value = True Then wdDoc.FormFields("tb5tn").CheckBox.Value = True
'If tb5nino.Value = True Then wdDoc.FormFields("tb5nino").CheckBox.Value = True
'If tb5o.Value = True Then wdDoc.FormFields("tb5o").CheckBox.Value = True
'If year1.Value = True Then wdDoc.FormFields("year1").CheckBox.Value = True
'If year2.Value = True Then wdDoc.FormFields("year2").CheckBox.Value = True
'If year3.Value = True Then wdDoc.FormFields("year3").CheckBox.Value = True
'If year4.Value = True Then wdDoc.FormFields("year4").CheckBox.Value = True
'If year5.Value = True Then wdDoc.FormFields("year5").CheckBox.Value = True
'If year6.Value = True Then wdDoc.FormFields("year6").CheckBox.Value = True
'If year7.Value = True Then wdDoc.FormFields("year7").CheckBox.Value = True
'If yeare.Value = True Then wdDoc.FormFields("yeare").CheckBox.Value = True
wdDoc.SaveAs ("name_" & ActiveSheet.Name & "_" & Range("Subject!B2") & "_" & Range("Subject!B3") & ".doc")
End If
wdApp.Visible = True
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
Set wdDoc = Nothing
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = "Information Request - " & Range("Subject!B2") & " " & Range("Subject!B3")
.To = Range("data!B7").Value ' <-- Put email of the recipient here
.CC = "" ' <-- Put email of 'copy to' recipient here
.bcc = Range("data!B9")
.Body = "Hi," & vbLf & vbLf _
& Range("data!b12") & vbLf & vbLf _
& Range("data!b13") & vbLf _
& Range("data!b14") & vbLf _
& Range("data!b15") & vbLf _
& "" & vbLf _
& Range("Subject!B15") & vbLf _
& Range("Subject!B17") & vbLf _
& Range("Data!B17") & vbLf _
& Range("data!B18") & vbLf _
& Range("data!B19") & vbLf _
& Range("Subject!B20") & vbLf & vbLf
.Attachments.Add (ThisWorkbook.Path & "\name_" & ActiveSheet.Name & "_" & Range("Subject!B2") & "_" & Range("Subject!B3") & ".doc")
' Try to send
On Error Resume Next
.Display ' or use .Send
Application.Visible = True
If Err Then
MsgBox Range("data!B23").Value, vbExclamation
Else
MsgBox Range("data!B22").Value, vbInformation
End If
On Error GoTo 0
End With
Kill (ThisWorkbook.Path & "\name_" & ActiveSheet.Name & "_" & Range("Subject!B2") & "_" & Range("Subject!B3") & ".doc")
' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit
If IsCreated Then wdApp.Quit
' Release the memory of object variable
Set OutlApp = Nothing
End Sub
Private Sub Copy_Cell_To_Form_Field(doc As Word.Document, cellValue As Variant, formFieldName As String)
Dim i As Integer
Dim wdFormField As Word.FormField
'Find the specified form field bookmark
Set wdFormField = Nothing
i = 1
While i <= doc.FormFields.Count And wdFormField Is Nothing
If doc.FormFields(i).Name = formFieldName Then Set wdFormField = doc.FormFields(i)
i = i + 1
Wend
If Not wdFormField Is Nothing Then
wdFormField.Result = cellValue
Else
MsgBox "Form field bookmark " & formFieldName & " doesn't exist in " & doc.Name
End If
End Sub