Hello everyone.
I wrote this function which fills MSWord templates, like the mail merge function, but customized to my needs. It basically extracts a query definition's SQL string, it concatenates the where clause and, using the first record, it finds the field names of the SQL string in the docx template, the placeholders in the template use this format {{fieldName}}. It then generates a file in the temporary folder of Windows and returns the path.
There's something trimming my strings to 255 characters. As you can see in the code, when the field is longer than 255 characters, it sends the contents of the field to the clipboard and then pastes it, instead of just using the field.value property, which would trim the text to 255 characters. That behaviour worked great until I decided to use a function to add 'minus' symbols to keep filling the blanks when the text ends.
Sounds weird, maybe? I'll try to explain further: Imagine a template with 4 blank lines that you have to fill, but your text is only half a line long, how do you fill the rest? well I chose the path of doing it with the Access Query Builder like this:
Suppose I need to fill 500 characters:
But if those 'minus' symbols exceed the length of 255, they get trimmed, sometimes it outputs n?n or ?;? at the end.
Please check the attached sample database. I suspect the problem is actually in the clipboard code, which is this:
I suspect that because I wrote a custom function to not use the built-in String function.
But it returns the same.
What could it be?
I wrote this function which fills MSWord templates, like the mail merge function, but customized to my needs. It basically extracts a query definition's SQL string, it concatenates the where clause and, using the first record, it finds the field names of the SQL string in the docx template, the placeholders in the template use this format {{fieldName}}. It then generates a file in the temporary folder of Windows and returns the path.
Code:
Function templateReplacer( _
querydef_name As String, _
where_clauses As String, _
template_path As String, _
desired_filename As String) _
As String
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 FunctionThere's something trimming my strings to 255 characters. As you can see in the code, when the field is longer than 255 characters, it sends the contents of the field to the clipboard and then pastes it, instead of just using the field.value property, which would trim the text to 255 characters. That behaviour worked great until I decided to use a function to add 'minus' symbols to keep filling the blanks when the text ends.
Sounds weird, maybe? I'll try to explain further: Imagine a template with 4 blank lines that you have to fill, but your text is only half a line long, how do you fill the rest? well I chose the path of doing it with the Access Query Builder like this:
Suppose I need to fill 500 characters:
IIf(Len[field]<500,String(500-Len([field]), "-"),"")But if those 'minus' symbols exceed the length of 255, they get trimmed, sometimes it outputs n?n or ?;? at the end.
Please check the attached sample database. I suspect the problem is actually in the clipboard code, which is this:
Code:
Option Compare Database
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, _
ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As LongPtr, _
ByVal hMem As LongPtr) As LongPtr
#Else
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long
#End If
Const GHND = &H42
Const CF_TEXT = 1
Const MAXSIZE = 4096
Function ClipBoard_SetData(MyString As String)
'PURPOSE: API function to copy text to clipboard
'SOURCE: www.msdn.microsoft.com/en-us/library/office/ff192913.aspx
#If VBA7 Then
Dim hGlobalMemory As LongPtr, lpGlobalMemory As LongPtr
Dim hClipMemory As LongPtr, x As LongPtr
#Else
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, x As Long
#End If
'Allocate moveable global memory
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
'Lock the block to get a far pointer to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
'Copy the string to this global memory.
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
'Unlock the memory.
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
'Open the Clipboard to copy data to.
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
'Clear the Clipboard.
x = EmptyClipboard()
'Copy the data to the Clipboard.
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End FunctionI suspect that because I wrote a custom function to not use the built-in String function.
Code:
Public Function StringX(amt As Long, str As String) As String
Dim finalString As String
Dim i As Long
For i = 1 To amt
finalString = finalString & str
Next
StringX = finalString
End FunctionWhat could it be?
