I have updated my MailNotification class with some additional functionality I needed at work. Since our mail system now is Outlook/Exchange, and therefore the Notes doc links don’t work anymore, I am in the process of converting all my email notifications into HTML email. The doc links are now made into HTML links, pointing to a notes:// or http:// address.
I simply added a new class, HTMLmail. It is based on the old NotesMail class, but I override a few functions that are different. This makes it very easy to update the emails I am generating in my Lotusscript agents, in most cases I only have to replace NotesMail with HTMLmail in the declaration and instantiation:
Dim maildoc As HTMLMail Set maildoc = New HTMLMail()
When I had doc links in the email I also had to modify the code where I generate it. The method takes three arguments: the NotesDocument to link to, the Alt/Title attribute for the link (to be displayed when hovering over the link) and the text of the link:
Call maildoc.AppendDocLink(doc,"Click to open",doc.ClaimNumber(0))
In order to generate the links I created a Link class, where you can set what protocol you want to use (“notes” or “http”) you want the link to use, you can change the port from the default of 80, and you can even force the link to point to a different server. I use this class in the AppendDocLink method in the HTMLmail class.
Here is a short code sample, it is just a function to create a mail notification for an insurance claim. The claim document is passed to the function and a mail is sent to the adjuster and his/her manager.
Sub SendNotification(doc as NotesDocument)
'*** Create a new object and set the sender, recipients and subject
Set maildoc = New HTMLMail()
maildoc.Principal = |"System Notification" <noreply@example.com>|
Call maildoc.AddMailTo(doc.GetItemvalue("Adjuster")(0))
Call maildoc.AddMailCC(GetManagerName(doc.GetItemValue("Adjuster")(0)))
maildoc.Subject = "30 DAY ALERT - " & doc.GetItemValue("ClaimNumber")(0)
'*** Build body content, including a link to the document
Call maildoc.AppendText("Claim number ")
Call maildoc.AppendDocLink(doc,"Click to open",doc.GetItemValue("ClaimNumber")(0))
Call maildoc.AppendText(" was received on ")
Call maildoc.AppendText(Format$(doc.GetItemValue("Received_Date")(0),"mm/dd/yyyy") & ". ")
Call maildoc.AppendText("This claim has been opened for 30 days. ")
Call maildoc.AppendText("Please confirm all appropriate actions has been performed.")
Call maildoc.AddNewLine(2)
'*** Add no-reply notification to the end and send the email
maildoc.NoReply = True
Call maildoc.Send()
'*** Flag the NotesDocument as processed and save it to avoid duplicate notifications
doc.Warning30daySent = "Yes"
Call doc.Save(True,True)
End Sub
That’s pretty much it. Enjoy the code, and as usual I do not guarantee anything. Use on your own risk, as always. If you like this code and use it, let me know.
Option Public
Option Declare
Class NotesMail
Public maildoc As NotesDocument
Public body As NotesRichTextItem
Private p_subject As String
Private p_sendto List As String
Private p_copyto List As String
Private p_blindcopyto List As String
Private p_principal As String
Public NoReply As Boolean
Public mailbox As NotesDatabase
Public Sub New()
Dim session As New NotesSession
Dim mailservername As String
' We must use mail.box on current server.
mailservername = session.Currentdatabase.Server
' Using mail.box directly is unsupported, but is the
' only way to make the mail look like it is actually
' sent from another address, in our case the principal.
Set mailbox = New NotesDatabase(mailservername,"mail.box")
If mailbox.Isopen = False Then
Print "mail.box on " & mailservername & " could not be opened"
Exit Sub
End If
Set me.maildoc = New NotesDocument(mailbox)
Call me.maildoc.ReplaceItemValue("Form","Memo")
'Set me.body = New NotesRichTextItem(maildoc,"Body")
Call CreateBody()
me.p_subject = ""
me.p_principal = ""
' Empty lists for addresses
Erase me.p_sendto
Erase me.p_copyto
Erase me.p_blindcopyto
me.NoReply = False ' Default is not to add a disclaimer to the end
End Sub
Private Sub CreateBody()
Set me.body = New NotesRichTextItem(maildoc,"Body")
End Sub
Public Property Set Subject As String
me.p_subject = FullTrim(Subject)
End Property
Public Property Get Subject As String
Subject = me.p_subject
End Property
Public Property Set Principal As String
me.p_principal = FullTrim(Principal)
End Property
Public Property Get Principal As String
Principal = me.p_principal
End Property
'*** Recipient address (mailto) functions
Public Property Set MailTo As String
me.p_sendto(FullTrim(MailTo)) = FullTrim(MailTo)
End Property
Public Property Get MailTo As String ' Get the first address only
ForAll mto In me.p_sendto
MailTo = mto
Exit ForAll
End ForAll
End Property
Public Property Set SendTo As String ' Alias for MailTo
MailTo = SendTo
End Property
Public Property Get SendTo As String ' Alias for MailTo
SendTo = MailTo
End Property
Public Sub AddMailTo(address As String) ' Additional address
me.p_sendto(address) = address
End Sub
Public Sub RemoveMailTo(address As String) ' Remove address from list
Erase me.p_sendto(address)
End Sub
' *** Functions for CC address
Public Property Set MailCC As String
me.p_copyto(FullTrim(MailCC)) = FullTrim(MailCC)
End Property
Public Property Get MailCC As String ' Get the first address only
ForAll mcc In me.p_copyto
MailCC = mcc
Exit ForAll
End ForAll
End Property
Public Sub AddMailCC(address As String)
me.p_copyto(address) = address
End Sub
Public Sub RemoveMailCC(address As String)
Erase me.p_copyto(address)
End Sub
' *** Functions for BCC address
Public Sub AddMailBCC(address As String)
me.p_blindcopyto(address) = address
End Sub
Public Property Set MailBCC As String
me.p_blindcopyto(FullTrim(MailBCC)) = FullTrim(MailBCC)
End Property
Public Property Get MailBCC As String ' Get the first address only
ForAll bcc In me.p_blindcopyto
MailBCC = bcc
Exit ForAll
End ForAll
End Property
Public Sub RemoveMailBCC(address As String)
Erase me.p_blindcopyto(address)
End Sub
' *** Functions for email body
Public Sub AppendText(bodytext As String)
Call me.body.AppendText(bodytext)
End Sub
Public Sub AppendDocLink(doc As NotesDocument, comment As String, linktext As String)
If FullTrim(linktext) = "" Then
Call me.body.AppendDocLink(doc, comment)
Else
Call me.body.AppendDocLink(doc, comment, linktext)
End If
End Sub
Public Sub AppendNewLine(cnt As Integer)
Call me.body.AddNewline(cnt)
End Sub
Public Sub AddNewLine(cnt As Integer)
Call me.body.AddNewline(cnt)
End Sub
Public Sub AttachFile(filename As String)
Call me.body.EmbedObject(1454,"",filename)
End Sub
' *** Send the mail
Public Sub Send()
Dim session As New NotesSession
Dim richStyle As NotesRichTextStyle
Dim recipients As String
If me.subject<,>,"" Then
maildoc.Subject = me.subject
End If
recipients = ""
If ListItemCount(me.p_sendto)>,0 Then
maildoc.SendTo = ListToArray(me.p_sendto)
recipients = recipients + Join(ListToArray(me.p_sendto),"~") + "~"
End If
If ListItemCount(me.p_copyto)>,0 Then
maildoc.CopyTo = ListToArray(me.p_copyto)
recipients = recipients + Join(ListToArray(me.p_copyto),"~") + "~"
End If
If ListItemCount(me.p_blindcopyto)>,0 Then
maildoc.BlindCopyTo = ListToArray(me.p_blindcopyto)
recipients = recipients + Join(ListToArray(me.p_blindcopyto),"~") + "~"
End If
maildoc.Recipients = FullTrim(Split(recipients,"~"))
If me.p_principal<,>,"" Then
Call maildoc.ReplaceItemValue("Principal", me.p_principal)
' If principal is set, we want to fix so mail looks like
' it is coming from that address, need to set these fields
Call maildoc.ReplaceItemValue("From", me.p_principal)
Call maildoc.ReplaceItemValue("Sender", me.p_principal)
Call maildoc.ReplaceItemValue("ReplyTo", me.p_principal)
Call maildoc.ReplaceItemValue("SMTPOriginator", me.p_principal)
End If
' If NoReply is set, append some red text...
If NoReply = True Then
Set richStyle = session.CreateRichTextStyle
richStyle.NotesFont = 4
richStyle.NotesColor = 2
richStyle.Bold = True
Call me.body.AppendStyle(richStyle)
Call me.body.AddNewLine(1)
Call me.body.AppendText("*** DO NOT REPLY TO THE SENDER OF THIS MESSAGE! ***")
Call me.body.AddNewLine(1)
Call me.body.AppendText("*** IT IS AN AUTOMATED SYSTEM MAIL ***")
End If
On Error Resume Next
'Call maildoc.CopyItem(body, "Body")
If me.p_principal<,>,"" Then
Call maildoc.Save(True,False) ' Save in mail.box
Else
Call maildoc.Send(False) ' Send mail normally
End If
End Sub
' *** Private functions called from within the class ***
' *** Convert list to array
Private Function ListToArray(textlist As Variant) As Variant
Dim i As Integer
Dim temparray() As String
ReDim temparray(0) As String
ForAll t In textlist
temparray(UBound(temparray)) = t
ReDim Preserve temparray(UBound(temparray)+1) As String
End ForAll
ListToArray = FullTrim(temparray)
End Function
' *** Count items in a list
Private Function ListItemCount(textlist As Variant) As Integer
Dim cnt As Integer
cnt = 0
ForAll t In textlist
cnt = cnt + 1
End ForAll
ListItemCount = cnt
End Function
End Class
%REM
Class HTMLMail
Description: Inherits from NotesMail class, implements additional functions
%END REM
Class HTMLMail As NotesMail
Private session As NotesSession
Private mimebody As NotesMIMEEntity
Private header As NotesMIMEHeader
Private stream As NotesStream
Private p_server As String
Private p_protocol As String
Private p_port As Integer
Public LinkServerOnly As Boolean
%REM
Sub CreateBody
Description: Override body creation with HTML body
%END REM
Private Sub CreateBody()
Dim db As NotesDatabase
Set session = New NotesSession()
Set db = session.CurrentDatabase
Set stream = session.CreateStream
session.ConvertMIME = False ' Do not convert MIME to rich text
Set me.mimebody = maildoc.CreateMIMEEntity
Call stream.writetext(|<,HTML>,|)
Call stream.writetext(|<,head>,|)
Call stream.writetext(|<,/head>,|)
Call stream.writetext(|<,body>,|)
Call stream.writetext(|<,div style="font-family: Calibri,Arial; font-size:12pt;">,|)
me.p_protocol = "notes"
me.p_port = 80
LinkServerOnly = False
End Sub
Public Sub AppendText(bodytext As String)
Call me.stream.writetext(bodytext)
End Sub
Public Sub AddNewLine(cnt As Integer)
Dim i As Integer
For i = 1 To cnt
Call me.stream.writetext("<,br>,")
Next
End Sub
Public Sub AppendNewLine(cnt As Integer)
Dim i As Integer
For i = 1 To cnt
Call me.stream.writetext("<,br>,")
Next
End Sub
Public Sub SetLinkServer(server As String)
Me.p_server = server
End Sub
Public Sub SetLinkProtocol(protocol As String)
Me.p_protocol = protocol
End Sub
Public Sub SetLinkPort(port As Integer)
Me.p_port = port
End Sub
Public Sub AppendDocLink(doc As NotesDocument, comment As String, linktext As String)
Dim html As String
Dim link As Link
Set link = New Link(doc)
Call link.SetProtocol(Me.p_protocol)
Call link.SetPort(Me.p_port)
If Me.p_server<,>,"" Then
Call link.SetServer(p_server)
End If
link.ServerOnly = LinkServerOnly
html = |<,a href="| & link.URL() + |"|
If FullTrim(linktext)<,>,"" Then
html = html + | title="| + comment + |" alt="| + comment + |"|
End If
html = html + ">," + linktext + "<,/a>,"
Call AppendText(html)
End Sub
Sub AddNoReplyNotification()
Call me.stream.writetext(|<,div style="font-family: consolas, courier; font-size: 10pt; color:#FF0000; margin-top: 25px; margin-bottom: 25px;">,|)
Call me.stream.writetext("***************************************************<,br>,")
Call me.stream.writetext("*** DO NOT REPLY TO THE SENDER OF THIS MESSAGE! ***<,br>,")
Call me.stream.writetext("*** IT IS AN AUTOMATED SYSTEM MAIL FROM LNP ***<,br>,")
Call me.stream.writetext("***************************************************<,br>,")
Call me.stream.writetext("<,/div>,")
If me.p_principal = "" Then
me.p_principal = |"Do Not Reply" <,noreply@deep-south.com>,|
End If
End Sub
' *** Send the mail
Public Sub Send()
Dim doc As NotesDocument
Dim recipients As String
maildoc.Form = "Memo"
'*** If NoReply is set, append some red text...
If NoReply = True Then
' Call stream.writetext(|<,p>,<,font color="red">,|)
' Call stream.writetext("*** DO NOT REPLY TO THE SENDER OF THIS MESSAGE! ***<,br>,")
' Call stream.writetext("*** IT IS AN AUTOMATED SYSTEM MAIL ***")
' Call stream.writetext("<,/font>,<,/p>,")
Call AddNoReplyNotification()
End If
'*** Add HTML for end of email
Call stream.writetext(|<,/div>,|)
Call stream.writetext(|<,/body>,|)
Call stream.writetext(|<,/html>,|)
Call mimebody.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT)
If me.subject<,>,"" Then
maildoc.Subject = me.subject
End If
recipients = ""
If ListItemCount(me.p_sendto)>,0 Then
maildoc.SendTo = ListToArray(me.p_sendto)
recipients = recipients + Join(ListToArray(me.p_sendto),"~") + "~"
End If
If ListItemCount(me.p_copyto)>,0 Then
maildoc.CopyTo = ListToArray(me.p_copyto)
recipients = recipients + Join(ListToArray(me.p_copyto),"~") + "~"
End If
If ListItemCount(me.p_blindcopyto)>,0 Then
maildoc.BlindCopyTo = ListToArray(me.p_blindcopyto)
recipients = recipients + Join(ListToArray(me.p_blindcopyto),"~") + "~"
End If
maildoc.Recipients = FullTrim(Split(recipients,"~"))
If me.p_principal<,>,"" Then
Call maildoc.ReplaceItemValue("Principal", me.p_principal)
' If principal is set, we want to fix so mail looks like
' it is coming from that address, need to set these fields
Call maildoc.ReplaceItemValue("From", me.p_principal)
Call maildoc.ReplaceItemValue("Sender", me.p_principal)
Call maildoc.ReplaceItemValue("ReplyTo", me.p_principal)
Call maildoc.ReplaceItemValue("SMTPOriginator", me.p_principal)
End If
On Error Resume Next
If me.p_principal<,>,"" Then
Call maildoc.Save(True,False) ' Save in mail.box
Else
Call maildoc.Send(False) ' Send mail normally
End If
session.ConvertMIME = True ' Restore conversion - very important
End Sub
End Class
%REM
Class Link
Description: Class for Doc Link functionality
%END REM
Class Link
Private p_protocol As String
Private p_server As String
Private p_domain As String
Private p_port As Integer
Private p_dbpath As String
Private p_docunid As String
Private p_Action As String
Private p_doc As NotesDocument
Private p_db As NotesDataBase
Public ServerOnly As Boolean
%REM
Sub New
Description: Constructor
%END REM
Public Sub New(doc As NotesDocument)
Dim server As NotesName
Set p_doc = doc
Set p_db = doc.Parentdatabase
Set server = New NotesName(p_db.Server)
Call SetServer(server.Common)
Call SetPort(80)
Call SetProtocol("notes") 'Set as default
ServerOnly = False
p_domain = GetDomain()
p_dbpath = doc.Parentdatabase.Filepath
p_docunid = doc.UniversalID
p_action = "OpenDocument"
End Sub
%REM
Sub SetProtocol
Description: Set the protocol to use (notes:, http:, https:)
%END REM
Public Sub SetProtocol(protocol As String)
Dim tmp As String
'*** Remove any : or /
tmp = Replace(protocol,":","")
tmp = Replace(tmp,"/","")
p_protocol = LCase(tmp) + ":"
If Not p_db Is Nothing Then
tmp = GetDomain()
Call SetDomain(tmp)
End if
End Sub
%REM
Sub SetAction
Description: Set the action, e.g. ?OpenDocument
%END REM
Public Sub SetAction(action As String)
Dim tmp As String
'*** Remove any ? if already there
tmp = Replace(action,"?","")
p_action = "?" + tmp
End Sub
%REM
Sub SetServer
Description: Override server name if we want another server
Do not specify the Notes domain or Internet domain name!
%END REM
Public Sub SetServer(servername)
p_server = servername
End Sub
Public Function GetDomain() As String
Dim tmp As String
Dim startpos As Integer
Dim endpos As Integer
If p_protocol = "notes:" Then
tmp = p_db.NotesURL
Else
tmp = p_db.HttpURL
End If
startpos = InStr(tmp,"://")+3
endpos = InStr(startpos,tmp,"/")
If endpos>,startpos Then
tmp = Mid$(tmp,startpos, endpos-startpos)
Else
tmp = "deep-south.com"
End If
GetDomain = tmp
End Function
%REM
Sub SetDomain
Description:Set the domain part of the URL, e.g. @Deep-South or .deep-south.com
%END REM
Public Sub SetDomain(domain As String)
p_domain = domain
End Sub
%REM
Sub SetPort
Description: Set the port number, e.g. 80 or 3000
%END REM
Public Sub SetPort(portnumber As Integer)
p_port = portnumber
End Sub
%REM
Function URL
Description: Get the URL for the document
%END REM
Public Function URL() As String
Dim tmp As String
tmp = p_protocol & "//"
If p_protocol<,>,"notes:" Then
tmp = tmp & p_server
If ServerOnly = False Then
tmp = tmp & "."
End if
End If
If ServerOnly = False Then
tmp = tmp & p_domain
End If
If p_protocol<,>,"notes:" Then
If p_port <,>, 80 Then
tmp = tmp & ":" & p_port
End If
End If
tmp = tmp & "/" & p_dbpath & "/0/" & p_docunid & "?" & p_action
tmp = Replace(tmp,Chr$(92),"/") 'Replace \ with / for URL
URL = tmp
End Function
End Class