Back in 2003 or so, I wrote some code to take a form letter (stored in a Notes document) and merge that with data stored in another Notes document in order to create a personalized letter that could be printed or emailed. Back then we were still on Notes 5, so very limited rich text functionality and no budget to purchase Ben’s excellent Midas LSX. The end result worked, but any formatting in the form letter template was lost.
Eventually we upgraded to Notes 7 and later to Notes 8.5. Now I had much more rich text functionality to play with, so I rewrote the code as a class. I added some additional functionality, like formatting values using a mask, and some lookup functionality. The class support all kind of formatting in the form letter template, including fonts, colors, tables, graphics, etc.
This is what a typical form letter look like:
As you can see, the placeholders are using curly brackets to hold either a field name or a command. The commands are indicated by the percent sign (%). There can also be different arguments, for formatting, lookup into the NAB/Domino Directory, etc. I even have functionality to present a nice dialog box where the user can pick recipient from a list of everyone associated with the claim (as this is from a claim system used by an insurance company).
Here is a description of the syntax for the placeholders:
|
{fieldname} {%DATE} {%TIME} {%INPUT PROMPT=”Please enter the amount” FORMAT=”$#,##0.00″ REQUIRED SETVAR=”variablename”} {%GETVAR NAME=”variablename”} {%USER} or {%USR} {%PICKLIST SERVER=”servername” DB=”database” VIEW=”viewname” FIELD=”fieldname” PROMPT=”text} {%PICKLIST VIEW=”viewname” FIELD=”fieldname” CACHED} |
And now the code, from a script library called Class.MailMerge.
Right now I don’t have the time to move the code out of my application and build a working sample database (the form letters are actually stored in a separate database), but I hope that this code can still help someone.
Option Public
Option Declare
'*** Script Library for MailMerge, preserving formatting in Rich Text field
'*** Requires Notes 6.5 or higher (tested in 7.0, 8.0 and 8.5)
'*** Copyright (c) Karl-Henry Martinsson 2003-2012
'*** Email: texasswede@gmail.com
'*** Websites: www.texasswede.com & blog.texasswede.com
'*** This code can be user in any application, as long as this notice
'*** is left intact. Also, the copyright information must be published in
'*** any documentation and on the About page, or similar location visible
'*** to the users, if they can not easily view/access the source code.
'*** If this code saves you time and helps you, consider a donation.
Const TYPE_FIELD = 1
Const TYPE_CMD = 2
Dim picklist List As NotesDocument
Dim variable List As String
Class PlaceHolderData
Public placeholderstring As String
Public placeholdertype As Integer
Public fieldname As String
Public fieldtype As Long
Public command As String
Public argument List As String
Public text As String
Public Sub New(Byval placeholder As String)
' Store the original placeholder
placeholderstring = placeholder
' Strip out curly brackets before and after
placeholder = Mid$(placeholder,2,Len(placeholder)-2)
If Left$(placeholder,1) = "%" Then ' Check if it is a command
Me.placeholdertype = TYPE_CMD
' Remove the % in front of the command
placeholder = Right$(placeholder,Len(placeholder)-1)
Else
Me.placeholdertype = TYPE_FIELD
End If
Call ParsePlaceHolder(placeholder)
End Sub
Private Sub ParsePlaceHolder(Byval placeholder As String)
Dim startpos As Integer
Dim midpos As Integer
Dim endpos As Integer
Dim args As Integer ' Boolean to indicate argements present or not
Dim argstring As String
Dim qt As Integer
Dim eq As Integer
Dim char As String
Dim argname As String
Dim argvalue As String
Dim i As Integer
' First we need to find the end of the command or field.
' It is either at the end of the placeholder or when we encounter a space
endpos = Instr(placeholder," ") ' Search for space
If endpos = 0 Then ' No space, e.g. no arguments
endpos = Len(placeholder)
args = False
Else ' We have some arguments
endpos = endpos -1 ' Reduce by one to get rid of trailing space
args = True
End If
If Me.placeholdertype = TYPE_CMD Then
Me.command = Ucase(Left$(placeholder,endpos))
Else
Me.fieldname = Left$(placeholder,endpos)
End If
If args = True Then
' Add code here to get arguments
argstring = Fulltrim(Right$(placeholder,Len(placeholder)-endpos) ) ' Get arguments only
qt = False
eq = False
For i = 1 To Len(argstring)
char = Mid$(argstring,i,1) ' Get character
If eq = True Then
argvalue=argvalue & char
Else
argname=argname & char
End If
If char = |"| Then ' We found a quote
If qt = False Then
qt = True
Else
qt = False
End If
Elseif char="=" Then ' Found a equal, e.g. now we are getting to a value
If eq = False Then
eq = True
Else
eq = False
End If
End If
If i = Len(argstring) Then ' We are at the end
char = " " ' Fake a space
End If
If char = " " Then ' Found a space
If qt = False Then ' Make sure it is not within quotes
eq = False ' Now we are back at argument name again
If Right$(argname,1) = "=" Then
argname = Left$(argname,Len(argname)-1) ' Remove trainling equal sign
End If
Me.argument(Ucase(argname)) = Fulltrim(Replace(argvalue,|"|,"")) ' Create list item, remove quotes
argname = ""
argvalue = ""
End If
End If
Next
End If
End Sub
Public Sub ProcessPlaceHolder(sourcedoc As NotesDocument, lossnotice As NotesDocument)
Dim session As New NotesSession
Dim thisdb As NotesDatabase
Dim ws As New NotesUIWorkspace
Dim pickcollection As NotesDocumentCollection
Dim pickdoc As NotesDocument
Dim servername As String
Dim dbname As String
Dim viewname As String
Dim fieldvalue As String
Dim formatstring As String
Dim inputstr As String
Dim prompt As String
Dim title As String
Dim default As String
Dim filterfield As String
Dim filtervalue As String
Dim nabdoc As NotesDocument
' Read any formatting specified in arguments
If Iselement(Me.argument("FORMAT")) Then
formatstring = Me.argument("FORMAT")
Elseif Iselement(Me.argument("FMT")) Then
formatstring = Me.argument("FMT")
Else
formatstring = ""
End If
If placeholdertype = TYPE_FIELD Then
If sourcedoc Is Nothing Then
Msgbox "Error: sourcedoc not defined, unable to retrieve data from field '" & Me.fieldname & "'.",,"MailMerge::PlaceHolder.ProcessPlaceHolder()"
fieldvalue = "*** ERROR ***"
Exit Sub
Else
If Iselement(Me.Argument("LOSSNOTICE")) Then
fieldvalue = lossnotice.GetItemValue(Me.fieldname)(0)
Me.FieldType = lossnotice.GetFirstItem(Me.fieldname).Type
Elseif Iselement(Me.Argument("SOURCE")) Then
If Ucase(Me.Argument("SOURCE")) = "LOSSNOTICE" Then
fieldvalue = lossnotice.GetItemValue(Me.fieldname)(0)
Me.FieldType = lossnotice.GetFirstItem(Me.fieldname).Type
End If
Else
fieldvalue = sourcedoc.GetItemValue(Me.fieldname)(0)
Me.FieldType = sourcedoc.GetFirstItem(Me.fieldname).Type
End If
If formatstring <> "" Then
If Isdate(fieldvalue) Then ' Check if it might be a date/time value
fieldvalue = Format$(Cdat(fieldvalue),formatstring)
Elseif Isnumeric(fieldvalue) Then ' Check if it might be a numeric value
fieldvalue = Format$(Cdbl(fieldvalue),formatstring)
End If
End If
End If
Me.text = fieldvalue
Else
' *** Fix legacy commands
If Ucase(Me.Command) = "USR" Then
Me.Command = "USER"
End If
' *** Process placeholder commands
Select Case Ucase(Me.Command)
Case "USER" :
If Iselement(Me.Argument("NABFIELD")) Then
Me.Text = GetNABField(session.CommonUserName, Me.Argument("NABFIELD"))
Else
Me.Text = session.CommonUserName
End If
Case "INPUT" : ' *** Ask the user to enter information
prompt = Me.Argument("PROMPT")
If Iselement(Me.Argument("TITLE")) Then
title = Me.Argument("TITLE")
Else
title = "FormLetter Mail Merge"
End If
If Iselement(Me.Argument("DEFAULT")) Then
default = Me.Argument("DEFAULT")
Else
default = ""
End If
If Iselement(Me.Argument("REQUIRED")) Then
' Repeat until user enter a value
Do
inputstr = Inputbox$(prompt, title, default)
Loop While Fulltrim(inputstr)=""
Else
inputstr = Inputbox$(prompt, title, default)
End If
If formatstring <> "" Then
If Isdate(inputstr) Then ' Check if it might be a date/time value
inputstr = Format$(Cdat(inputstr),formatstring)
Elseif Isnumeric(inputstr) Then ' Check if it might be a numeric value
inputstr = Format$(Cdbl(inputstr),formatstring)
End If
End If
Me.Text = inputstr
' *** Check for SETVAR argument
If Iselement(Me.argument("SETVAR")) Then
variable(Ucase(Me.argument("SETVAR")))=Me.Text
End If
Case "PICKLIST" : ' Present the user with a list of documents to choose from
Set thisdb = session.CurrentDatabase
Set pickdoc = Nothing ' Clear pickdoc
' *** We need to get the view argument to perform a lookup into the list...
If Iselement(Me.Argument("VIEW")) Then
viewname = Ucase(Me.Argument("VIEW"))
End If
' *** If CLAIMANT argument is specified, set arguments to predefined values
If Iselement(Me.Argument("CLAIMANT")) Then
Me.Argument("VIEW") = "(SysLookupClaimantsCatByParentUNID)"
Me.Argument("FILTER") = "ParentUNID"
Me.Argument("PROMPT") = "Select Claimant:"
End If
' *** Check if user requested to clear cached data
If Iselement(Me.Argument("CLEARCACHE")) Then
If Iselement(picklist(viewname)) Then
Erase picklist(viewname) ' Delete this cached item (document)
End If
End If
' *** If user want to use cached data, load pickdoc with cached data
If Iselement(Me.Argument("CACHED")) Then
If Iselement(picklist(viewname)) Then
Set pickdoc = picklist(viewname)
End If
End If
If pickdoc Is Nothing Then ' No cached document for this view
If Iselement(Me.Argument("SERVER")) Then
servername = Me.Argument("SERVER")
Else
servername = thisdb.Server
End If
If Iselement(Me.Argument("DB")) Then
dbname = Me.Argument("DB")
Else
dbname = thisdb.FilePath
End If
If Iselement(Me.Argument("VIEW")) Then
viewname = Me.Argument("VIEW")
Else
Msgbox "Missing Required Argument - VIEW" & Chr$(13) & Me.PlaceHolderString,,"Missing Argument"
Exit Sub
End If
If Iselement(Me.Argument("PROMPT")) Then
prompt = Me.Argument("PROMPT")
Else
Msgbox "Missing Required Argument - PROMPT" & Chr$(13) & Me.PlaceHolderString,,"Missing Argument"
Exit Sub
End If
If Iselement(Me.Argument("TITLE")) Then
title = Me.Argument("TITLE")
Else
title = "FormLetter Mail Merge"
End If
onemoretime:
If Iselement(Me.Argument("FILTER")) Then
filterfield = Me.Argument("FILTER") ' Get field to filter on
filtervalue = sourcedoc.GetItemValue(filterfield)(0) ' Get value of field on source document
Set pickcollection = ws.PicklistCollection(3, False, servername, dbname, viewname, title, prompt, filtervalue)
Else
Set pickcollection = ws.PicklistCollection(3, False, servername, dbname, viewname, title, prompt)
End If
If Isempty(pickcollection) Then
If Iselement(Me.Argument("REQUIRED")) Then
If Ucase(Me.Argument("REQUIRED")) <> "NO" Then
Msgbox "You need to select one item/document in the list.", , title
Goto onemoretime
End If
End If
Else
Set pickdoc = pickcollection.GetFirstDocument
End If
If pickdoc Is Nothing Then
Msgbox "Error: No document returned.",,"MailMerge::PlaceHolder.ProcessPlaceHolder()"
Exit Sub
End If
Set picklist(Ucase(viewname)) = pickdoc
End If
If Iselement(Me.Argument("FIELD")) Then
fieldname = Me.Argument("FIELD")
Else
Msgbox "Missing Required Argument - FIELD" & Chr$(13) & Me.PlaceHolderString,,"Missing Argument"
Exit Sub
End If
inputstr = pickdoc.GetItemValue(fieldname)(0)
If formatstring <> "" Then
If Isdate(inputstr) Then ' Check if it might be a date/time value
inputstr = Format$(Cdat(inputstr),formatstring)
Elseif Isnumeric(inputstr) Then ' Check if it might be a numeric value
inputstr = Format$(Cdbl(inputstr),formatstring)
End If
End If
Me.Text = inputstr
' *** Check for SETVAR argument
If Iselement(Me.argument("SETVAR")) Then
variable(Ucase(Me.argument("SETVAR")))=Me.Text
End If
Case "DATE" : ' *** Current Date
If formatstring = "" Then
Me.Text = Format$(Now(),"mm/dd/yyyy")
Else
Me.Text = Format$(Now(),formatstring)
End If
Case "TIME" : ' *** Current Time
If formatstring = "" Then
Me.Text = Format$(Now(),"hh:nn:ss")
Else
Me.Text = Format$(Now(),formatstring)
End If
Case "GETVAR" : ' *** Get variable previously stored
If Iselement(variable(Ucase(Me.argument("NAME")))) Then
Me.Text = variable(Ucase(Me.argument("NAME")))
End If
Case Else :
Me.Text = "**** undefined command ***"
End Select
End If
End Sub
' *** Private supporting functions/subs
Private Function GetNABField(user As String, fieldname As String) As String
Dim session As New NotesSession
Dim curdb As NotesDatabase
Dim nabdb As NotesDatabase
Dim view As NotesView
Dim col As NotesDocumentCollection
Dim userdoc As NotesDocument
Set curdb = session.CurrentDatabase
Set nabdb = New Notesdatabase(curdb.Server, "names.nsf")
Set view = nabdb.GetView("PeopleByFirstname")
Set col = view.GetAllDocumentsByKey(user)
If col Is Nothing Then
GetNABField = ""
Exit Function
End If
Set userdoc = col.GetFirstDocument
If userdoc Is Nothing Then
GetNABField = ""
Exit Function
End If
GetNABField = userdoc.GetItemValue(fieldname)(0)
End Function
End Class
Class MailMergeObject
Public templatedoc As NotesDocument ' Where to get layout from
Public sourcefield As NotesRichTextItem
Public targetfield As NotesRichTextItem ' Where to put the merged text
Public placeholder List As PlaceHolderData
Private sourcedoc As NotesDocument ' The document containing data to be merged
Private maindoc As NotesDocument ' The main document for the processed document
Private tempbody As NotesRichTextItem ' Temporary copy of body field for this class/instance
Public Sub New()
End Sub
Public Sub SetSourceDoc(doc As NotesDocument)
Set sourcedoc = doc
End Sub
Public Sub SetMainDoc(doc As NotesDocument)
Set maindoc = doc
End Sub
Public Function LoadTemplate() As Integer
Dim body As NotesRichTextItem
Dim temp As String
Dim bodytext As String
Dim startpos As Long
Dim endpos As Long
Set sourcefield = templatedoc.GetFirstItem("Body") ' Put template body field (rich text) into global object
Set body = sourcefield ' Put rich text into temporary body object
bodytext = body.GetUnformattedText()
startpos = Instr(bodytext,"{")
Do While startpos > 0
endpos = Instr(startpos,bodytext,"}")
If endpos>0 Then
temp = Mid$(bodytext,startpos,endpos-startpos+1)
Set placeholder(temp & "~" & startpos) = New PlaceHolderData(temp) ' Add to list of placeholder objects
End If
startpos = Instr(endpos,bodytext,"{")
Loop
End Function
Public Function MergedRichText() As NotesRichTextItem
Dim range As NotesRichTextRange
Dim cnt As Integer
Set tempbody = sourcefield
Set range = tempbody.CreateRange
Forall p In placeholder
Call p.ProcessPlaceHolder(sourcedoc, maindoc)
If p.text = "" Then
p.text = " -- "
End If
cnt = range.FindAndReplace(p.placeholderstring, p.text, 1+4+8+16)
End Forall
Call tempbody.Compact
Call tempbody.Update
Set targetfield = tempbody
Set MergedRichText = tempbody
End Function
Public Function Content() As NotesRichTextItem
Set Content = targetfield
End Function
End Class
I will try to post some sample code later, using this script library.