UPDATE: May 28, 2010 – fixed errors caused by default Option Declare. Thanks to Lisa Harnett for the feedback!
UPDATE: Oct 19, 2010 – fixed Quit(). Thanks to Vance for the feedback! Also, clarified tokens.
Based on the feedback on my Lotus Notes mail merge from a Microsoft Excel spreadsheet (2009), I've refined my merge script to make it more awesome. How is it more awesome?
- Prompts you for drafting or sending
- Saves sent messages
- Allows you to customize the subject
- Uses [ ] instead of < and > for built-in tokens ([to], [cc], [subject]) for less HTML confusion in blog posts and replies
- Displays number of sent messages and errors
- Closes the Microsoft Excel spreadsheet afterwards
The search-and-replace tokens are defined in the first row of your Microsoft Excel spreadsheet. The script searches for them in the message body, replaces them with the appropriate values from the current row, and either saves the message as the draft or sends the message. There are a few built-in tokens for this script ([to], [cc], [subject]) – these are case-sensitive, so enter them exactly like that. All the other tokens are up to you, so you could use FOO and BAR as search-and-replace tokens if you want.
Tokens are replaced only in the message body. If you want a variable subject line, use a formula to calculate the subject in a column with the [subject] header.
As always, test your mail merges with a small list before using it for your entire list. Create an agent and call it something like “Mail merge”. Edit the agent and set the type to LotusScript. In the (Declarations) section, add
%Include "lsconst.lss"
In the “Initialize” section, put in:
Sub Initialize
'Mail merge script by Sacha Chua (sacha@sachachua.com)
Dim ws As NotesUIWorkspace
Set ws = New NotesUIWorkspace
Dim sendTypes(1) As String
Dim sendValue As String
Dim errorCount As Integer
errorCount = 0
sendTypes(0) = "Draft messages without sending"
sendTypes(1) = "Send messages"
sendValue = ws.Prompt(PROMPT_OKCANCELLIST, "Sending options", "What would you like to do?", "", sendTypes)
If (sendValue = "") Then
Exit Sub
End If
Dim fileName As String
Dim strXLFilename As String
'Prompt for the filename - should be a Microsoft Excel file with columns, where the first row of each column
'is a token that will be used when replacing text in the body of the message
'Special tokens: [to], [cc], [subject] set the appropriate fields
'Make sure the first column does not have any blank cells
fileName$ = ws.Prompt(12, "Select file", "3")
If fileName$ = "" Then
Exit Sub 'Cancel was pressed
End If
strXLFilename = fileName$
Dim s As New NotesSession
Dim uidoc As NotesUIDocument
Dim partno As String
Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Dim collection As NotesDocumentCollection
Dim memo As NotesDocument
Dim body As NotesRichTextItem
Dim newBody As NotesRichTextItem
Dim range As NotesRichTextRange
Dim count As Integer
Set db = s.CurrentDatabase
Set collection = db.UnprocessedDocuments
Set memo = collection.getFirstDocument()
Dim varXLFile As variant
'Get data from the spreadsheet
Set varXLFile = CreateObject("Excel.Application")
varXLFile.Visible = False
Dim varXLWorkbook As variant
Set varXLWorkbook = Nothing
varXLFile.Workbooks.Open strXLFilename
Set varXLWorkbook = varXLFile.ActiveWorkbook
Dim varXLSheet As variant
Set varXLSheet = varXLWorkbook.ActiveSheet
Dim lngRow As Integer
Dim columnNo As Integer
Dim token As String
Dim value As string
lngRow = 2
Dim maildoc As NotesDocument
While (Not (varXLSheet.Cells(lngRow, 1).Value = ""))
'Fill in the template
Dim subject As string
subject = memo.Subject(0)
Set body = memo.GetFirstItem("Body")
'Compose message
Set maildoc = New NotesDocument(db)
Set maildoc= db.CreateDocument()
maildoc.Form = "Memo"
maildoc.Subject = subject
Set newBody = maildoc.CreateRichTextItem("Body")
Call newBody.appendRTItem(body)
Set range = newBody.CreateRange
'Count the number of fields
'Look up tokens from the column headings and replace them
columnNo = 1
While Not(varXLSheet.Cells(1, columnNo).Value = "")
token = varXLSheet.Cells(1, columnNo).Value
value = varXLSheet.Cells(lngRow, columnNo).Value
count = range.FindAndReplace(token, value, 16)
If (token = "[to]") Then
maildoc.SendTo = value
End If
If (token = "[cc]") Then
maildoc.CopyTo = value
End If
If (token = "[subject]") Then
maildoc.Subject = value
End If
columnNo = columnNo + 1
Wend
On Error GoTo save
If (sendValue = sendTypes(0)) Then
Call maildoc.Save(True, False)
Else
maildoc.SaveMessageOnSend = True
maildoc.PostedDate = Now()
Call maildoc.Send(False)
Call maildoc.Save(True, True)
End If
GoTo nextrow
save:
MessageBox("Error processing " + maildoc.sendTo)
errorCount = errorCount + 1
Resume Next
nextrow:
lngRow = lngRow + 1
Wend
If (sendValue = sendTypes(0)) Then
MsgBox "Drafted " & (lngRow - errorCount - 2) & " message(s). Errors: " & errorCount
Else
MsgBox "Sent " & (lngRow - errorCount - 2) & " message(s). Errors: " & errorCount
End If
Call varXLFile.Quit()
End Sub