The script is this one...
http://sachachua.com/blog/p/7189/
It does not create an email per se. It takes a normal (any) email, replaces some variables like [User name] or anything one wishes to be customized in mail merge, and then creates bunch of emails to be sent to different addresses.
If you let it to create only drafts, they look just fine, you go in draft, send it manualy, and it arrives OK.
If you let these emails not saved as drafts but send as emails directly, there the formatting is lost (if sent outside Lotus Notes).
--------------
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
Feedback response number WEBB8TVTDY created by Frantisek Sasek on 05/01/2012
 Rich text format email not preserve... (Frantisek Sasek... 1.May.12)
. . Can you show the code you use for c... (Carl Tyler 1.May.12)
. . . . Code (Frantisek Sasek... 1.May.12)
 . . . . ..to be more precise (Frantisek Sasek... 1.May.12)
. . . . ..any update, please? (Frantisek Sasek... 13.May.12) |
..to be more precise
Return to top
