This is the complete code:
Code:
Private Sub cmdsummit_Click()
Dim CurSec() As String, PrevSec As String
Dim strSavePath As String
Dim strSaveName As String
Dim db As DAO.Database
Dim rsMailmerge As Recordset
strSavePath = DLookup("Variable", "tblVariable", "VariableID=16")
strSaveName = "QA Form " & Format(Now(), "yyyymmmdd_hhmmss") & " " & Me.cboSupervisor.Column(1) & ".doc"
With CurrentDb.OpenRecordset("select refid,standarddoc,score from qryQAMatrix where QAID=" & txtQAID & "")
' If .BOF And .EOF Then Exit Sub
Dim wa As New Word.Application
Dim wd As Word.Document
Dim bk As Word.Bookmark
With wa
.Visible = True
.Activate
.ScreenUpdating = False
End With
Set wd = wa.Documents.Open("L:\Templates\Health Check.dot")
strTextFile = cboForms.Column(1)
createKFIMailMergefile strPath, strTextFile & ".txt"
If Me.cboForms <> 7 Then
Set bk = wd.Bookmarks("InsertTable")
Dim wt As Word.Table, wr As Word.Row
'Set wt = wd.Tables.Add(wd.Parent.Selection.Range, 1, 3)
Set wt = wd.Tables.Add(bk.Range, 1, 3)
wt.Columns(1).Width = 60
wt.Columns(2).Width = 400
wt.Columns(3).Width = 70
RowFormat wt.Range, False
Do Until .EOF
CurSec = Split(.Fields(0), ".")
Set wr = wt.Rows.Add
' wr.Cells(1).Range.Text = CurSec(1) & "." & CurSec(2)
wr.Cells(1).Range.Text = .Fields(0)
wr.Cells(2).Range.Text = .Fields(1)
If .Fields(2).Value = 1 Then
wr.Cells(3).Range.Text = "Yes"
ElseIf .Fields(2).Value = 2 Then
wr.Cells(3).Range.Text = "No"
Else
wr.Cells(3).Range.Text = "N/A"
End If
If Not CurSec(0) = PrevSec Then
'new section, create a header
PrevSec = CurSec(0)
Set wr = wt.Rows.Add(wr)
If cboForms.Value = 1 Then
wr.Cells(1).Range.Text = SecName(Me.cboArea.Value)
Else
wr.Cells(1).Range.Text = SecName(CurSec(0))
End If
'wr.Cells(1).Range.Text = CurSec
wr.Cells(3).Range.Text = "Response"
wd.Range(wr.Cells(1).Range.Start, wr.Cells(2).Range.End).Cells.Merge
RowFormat wr.Range, True
End If
.MoveNext
Loop
wt.Rows(1).Delete
End If
End With
wd.MailMerge.MainDocumentType = 0
wd.MailMerge.Destination = wdSendToNewDocument
wd.MailMerge.OpenDataSource (strPath & strTextFile & ".txt")
wd.MailMerge.Execute
'Go through all created doc and remove all mail merge errors
For I = 1 To wd.Application.Documents.Count
If InStr(1, wa.Application.Documents(I).Name, "Error") <> 0 Then
wa.Application.Documents.Item(I).Close False
I = I - 1
End If
If I = wa.Application.Documents.Count Then Exit For
Next I
'Save merged document as new file
wa.ActiveDocument.AttachedTemplate.Saved = True
wd.Application.Documents.Item(1).SaveAs strSavePath & strSaveName, , , , False, , True
'Go through all created doc and close them
For I = 1 To wa.Application.Documents.Count
wa.Application.Documents.Item(wa.Application.Documents.Count).Close False
Next I
'delete the text file
Kill strPath & strTextFile & ".txt"
'delete the subs
exithere:
wa.Quit
Set wd = Nothing
Set wa = Nothing
Set qry = Nothing
Set db = Nothing
MsgBox ("Export Completed")
Application.FollowHyperlink strSavePath & strSaveName
Exit Sub
With wd.Parent
.ScreenUpdating = True
End With
End Sub