Function templateReplacer( _
querydef_name As String, _
where_clauses As String, _
template_path As String, _
desired_filename As String) _
As String
' This function has the purpose of filling .docx templates using a recordset
' from a ms access query definition, as an alternative for mail merge.
'
' It outputs a the location of the resulting file as a string,
' appending date and time to the filename to (try to) avoid duplicates
' and saving it in the temp folder of Windows.
'
' querydef_name: name of a query definition in the current db
' where_clauses: where clauses
' template_path: full path to the template docx
' desired_filename: how you want to call your resulting .docx, without path and extension
'
' To use it in word documents with docx extension, just add the fields to the template like this {{field}}
' The fields you specify in the template must have the same name as those in the query definition
On Error GoTo errHandler
Dim sql1 As String
sql1 = CurrentDb.QueryDefs(querydef_name).sql
Dim sql2 As String
sql2 = Replace(sql1, ";", " WHERE " & where_clauses)
Debug.Print sql2
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset(sql2)
Dim oWord As Object
Set oWord = CreateObject("Word.Application")
Dim oDoc As Object
Set oDoc = oWord.Documents.Open(template_path)
' |------------------- REPLACE {{FIELDS}} -------------------|
Dim field As Variant
Dim emptyFields As String
emptyFields = ""
Dim oStory As Object
For Each field In rs.Fields
Debug.Print field.Name, field.Value
For Each oStory In oDoc.StoryRanges
Do
With oStory.Find
If Len(field) > 255 Then
ClipBoard_SetData field.Value
.Execute FindText:="{{" & field.Name & "}}", ReplaceWith:="^c", _
Format:=True, Replace:=2
Else
.Execute FindText:="{{" & field.Name & "}}", ReplaceWith:=Nz(field, ""), _
Format:=True, Replace:=2
End If
End With
Set oStory = oStory.Next
Loop Until oStory Is Nothing
Next oStory
If IsNull(field) Then
emptyFields = emptyFields & vbCr & field.Name
End If
Next field
' |------------------- FILE NAMING AND SAVING -------------------|
Dim tempFolder As String
tempFolder = Environ("Temp")
Dim outputFullPath As String
outputFullPath = tempFolder & "\" & desired_filename & Format(Date, "ddmmyy") & Format(Time, "hhmmss") & ".docx"
oDoc.SaveAs2 outputFullPath
Set oWord = Nothing
Set oDoc = Nothing
If Len(emptyFields) > 0 Then
MsgBox "Empty fields: " & vbCr & emptyFields
End If
templateReplacer = outputFullPath
errHandler:
If Err.Number <> 0 Then
MsgBox Err.Number & vbCr & Err.Description
End If
Set oWord = Nothing
Set oDoc = Nothing
End Function