Lotus VB script - email generator - add button
HotSpot, VBScript, Lotus hotspot, Lotus Notes 6.x
Hi All,Ive got a vb sctipt (below), which will generate a load of emails in notes (v6.5) from an excel spreadsheet.
Ive worked out how to do things like bold/red text, however i now want to add in a button hotspot, which, when clicked, will reply to my email i sent the user, with some text "xxxx".
I know this is easy to do in notes using a hotspot button. but what would the vb code for this be?
I want to add it in after
".AppendText "If your account is still being used, we appologise for any inc...."
----vb code---
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Sub GenerateEmail()
' Macro to mail out Movers reports for reviews by line managers
' Setup an error handler to report any errors during mail sending
' On Error GoTo SendMailError
' Setup key variables
Dim objNotesSession As Object
Dim NotesOpen As Long
Dim objNotesMailFile As Object
Dim objNotesDocument As Object
Dim objNotesStyle As Object
Dim objNotesField As Object
Dim dataSheet, reportSheet, moversSheet
Dim EmailCCTo, EMailSendTo, templateSubject, templateHeader, templateFooter, currRow, reportRow, reqRow
Dim Sender, userGBID, userName, ManagerEmail, userEmail, foundPerm, endedPerm, tmpString, linesCnt, saveSendFlag
Dim nonPermUsers, numNonPermUsers, reportSheetName, reportSheetRow, Count
'Check if Lotus Notes is open or not.
NotesOpen = FindWindow("NOTES", vbNullString)
If NotesOpen = 0 Then
MsgBox "Notes must be open to run this script!", vbExclamation
Exit Sub
End If
' Note the worksheets we are using
Set dataSheet = ActiveWorkbook.Sheets("DATA")
Set reportSheet = ActiveWorkbook.Sheets("reason")
Set moversSheet = ActiveWorkbook.Sheets("leavers")
' Extract the send/save flag
saveSendFlag = ActiveWorkbook.Sheets("Instructions").Cells(5, 7).Value
' Extract the templates for the subject, header and footer, cc, bcc
templateSubject = dataSheet.Cells(5, 13).Value
templateHeader = dataSheet.Cells(5, 14).Value
templateFooter = dataSheet.Cells(5, 15).Value
Sender = dataSheet.Cells(5, 17).Value
' Create a blank string to hold all the GBIDs of users who have no permissions within the list
nonPermUsers = ""
numNonPermUsers = 0
' Pop up the status dialog to notify user of progress
Dim statusDialog As UserForm1
Set statusDialog = New UserForm1
' Initialise the captions
statusDialog.Label2.Caption = "1"
' Make the form visible
statusDialog.Show
' Iterate through all user names in the movers list
currRow = 4
While moversSheet.Cells(currRow, 1).Value <> ""
' Update progress dialog
statusDialog.Label2.Caption = CStr(currRow - 3)
statusDialog.Repaint
' extract details from the movers row
userGBID = UCase(Trim(moversSheet.Cells(currRow, 1).Value))
userName = moversSheet.Cells(currRow, 2).Value & " " & moversSheet.Cells(currRow, 3).Value
userEmail = moversSheet.Cells(currRow, 4).Value
ManagerEmail = moversSheet.Cells(currRow, 5).Value
' If any of the emails are blank, just replace with that users name
If userEmail = "" Then userEmail = userName
' Iterate through all the permissions provided to check the user has any relevant permissions, as if not then nothing to send
reqRow = 4
' Mult-page permission sheets coding
reportSheetRow = 6
reportSheetName = dataSheet.Cells(reportSheetRow, 18).Value
Set reportSheet = ActiveWorkbook.Sheets(reportSheetName)
foundPerm = False
endedPerm = False
While Not foundPerm And Not endedPerm
' Check if this is the end row for a sheet and if so, roll onto the next sheet
If reportSheet.Cells(reqRow, 1).Value = "" Then
reportSheetRow = reportSheetRow + 1
reportSheetName = dataSheet.Cells(reportSheetRow, 18).Value
If reportSheetName = "" Or reportSheetName = "END OF LIST" Then
endedPerm = True
Else
' Restart on next page
Set reportSheet = ActiveWorkbook.Sheets(reportSheetName)
reqRow = 4
End If
Else
' Note if find any permissions entries
' UCase (Trim(reportSheet.Cells(reqRow, 1).Select))
If UCase(Trim(reportSheet.Cells(reqRow, 1).Value)) = userGBID Then
foundPerm = True
End If
reqRow = reqRow + 1
End If
Wend
' If there are any permissions noted then connect to lotus and start building the email, else add to non perms list
If foundPerm = False Then
numNonPermUsers = numNonPermUsers + 1
' Add the user GBID into list for later display as no email will be sent
If nonPermUsers = "" Then
nonPermUsers = "- " & userGBID
Else
nonPermUsers = nonPermUsers & "," & vbCrLf & "- "
' Add a new line on every 5th one to fill out the dialog box sensibly
If numNonPermUsers Mod 5 = 0 Then
nonPermUsers = nonPermUsers & Chr(10)
End If
nonPermUsers = nonPermUsers & userGBID
End If
Else
' Setup all the core email fields and header
EMailSendTo = userEmail '' Required - Send to address
EmailCCTo = ManagerEmail
' Establish Connection to Notes
Set objNotesSession = CreateObject("Notes.NotesSession")
' Establish Connection to Mail File
Set objNotesMailFile = objNotesSession.GETDATABASE("", "")
' Open Mail
objNotesMailFile.OPENMAIL
' Create New Memo
Set objNotesDocument = objNotesMailFile.CreateDocument
' Create 'Subject Field' - replace template fields with correct values
tmpString = Replace(templateSubject, "<USERNAME>", userName)
tmpString = Replace(tmpString, "<USERGBID>", userGBID)
Set objNotesField = objNotesDocument.AppendItemValue("Subject", tmpString)
' Create 'Send To' Field
Set objNotesField = objNotesDocument.AppendItemValue("SendTo", EMailSendTo)
'create 'cc' field
Set objNotesField = objNotesDocument.AppendItemValue("CopyTo", EmailCCTo)
' Note the sender as configured
Set objNotesField = objNotesDocument.AppendItemValue("From", Sender)
objNotesDocument.Principal = Sender
' Create 'Body' of memo
Set objNotesField = objNotesDocument.CREATERICHTEXTITEM("Body")
Set objNotesStyle = objNotesSession.CreateRichTextStyle
' Add header
tmpString = Replace(templateHeader, "<USERNAME>", userName)
tmpString = Replace(tmpString, "<USERGBID>", userGBID)
With objNotesField
'.AppendText tmpString
.AppendText "Dear "
.AppendText userName
.AppendText ","
.AddNewLine (2)
.AppendText ""
objNotesStyle.Bold = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText userGBID
objNotesStyle.Bold = False
Call objNotesField.appendstyle(objNotesStyle)
.AppendText " as one which is potentially not in use anymore and so should be removed."
.AddNewLine (2)
.AppendText "Using our historical records, we have found the following information about your ID "
objNotesStyle.Bold = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText userGBID
objNotesStyle.Bold = False
Call objNotesField.appendstyle(objNotesStyle)
.AppendText ":"
.AddNewLine (2)
.AppendText "********************************************************************"
.AddNewLine (2)
End With
' Iterate through the permissions list report and generate lines for each permission
reportRow = 4
linesCnt = 0
' Mult-page permission sheets coding
reportSheetRow = 6
reportSheetName = dataSheet.Cells(reportSheetRow, 18).Value
Set reportSheet = ActiveWorkbook.Sheets(reportSheetName)
endedPerm = False
While Not endedPerm
' Check if this is the end row for a sheet and if so, roll onto the next sheet
If reportSheet.Cells(reportRow, 1).Value = "" Then
reportSheetRow = reportSheetRow + 1
reportSheetName = dataSheet.Cells(reportSheetRow, 18).Value
If reportSheetName = "" Or reportSheetName = "END OF LIST" Then
endedPerm = True
Else
' Restart on next page
Set reportSheet = ActiveWorkbook.Sheets(reportSheetName)
reportRow = 4
End If
Else
' Where a match is found, add a line to the memo
If UCase(Trim(reportSheet.Cells(reportRow, 1).Value)) = userGBID Then
' Increment count of retrievals listed
linesCnt = linesCnt + 1
' Build text for line - App name - (account id) (if not same as GBID) permissions
tmpString = reportSheet.Cells(reportRow, 2).Value
With objNotesField
objNotesStyle.Bold = True
objNotesStyle.NotesColor = 2
Call objNotesField.appendstyle(objNotesStyle)
.AppendText tmpString
.AddNewLine 1
objNotesStyle.Bold = False
objNotesStyle.NotesColor = 0
Call objNotesField.appendstyle(objNotesStyle)
End With
End If
reportRow = reportRow + 1
End If
Wend
With objNotesField
.AddNewLine (1)
.AppendText "********************************************************************"
.AddNewLine (2)
.AppendText "If your account is still being used, we appologise for any incovience caused by this email. To ensure that your account stays active and is NOT removed, you must relpy to this email stating why the above information is incorrect. This will allow our records to be updated"
.AddNewLine (2)
objNotesStyle.NotesColor = 4
objNotesStyle.Bold = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText "Please respond to this email by COB on Friday 9th May 2008."
objNotesStyle.NotesColor = 0
objNotesStyle.Bold = False
Call objNotesField.appendstyle(objNotesStyle)s
.AddNewLine (1)
End With
' Add footer
tmpString = Replace(templateFooter, "<USERNAME>", userName)
tmpString = Replace(tmpString, "<USERGBID>", userGBID)
With objNotesField
'point 1
.AddNewLine (1)
objNotesStyle.Bold = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText "- Monday 12th May 2008: "
objNotesStyle.Bold = False
Call objNotesField.appendstyle(objNotesStyle)
.AppendText " *"
objNotesStyle.Bold = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText userGBID
objNotesStyle.Bold = False
Call objNotesField.appendstyle(objNotesStyle)
.AppendText "*"
'point 2
.AddNewLine (1)
objNotesStyle.Bold = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText "- Wednesday 14th May 2008: "
objNotesStyle.Bold = False
Call objNotesField.appendstyle(objNotesStyle)
.AppendText " s."
'point 3
.AddNewLine (1)
objNotesStyle.Bold = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText "- Monday 26th May 2008: "
objNotesStyle.Bold = False
Call objNotesField.appendstyle(objNotesStyle)
.AppendText " o."
'point 4
.AddNewLine (1)
objNotesStyle.Bold = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText "- Monday 9th June 2008: "
objNotesStyle.Bold = False
Call objNotesField.appendstyle(objNotesStyle)
.AppendText "Delete the windows logon account *"
objNotesStyle.Bold = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText userGBID
objNotesStyle.Bold = False
Call objNotesField.appendstyle(objNotesStyle)
.AppendText "*"
.AddNewLine (1)
'.AppendText tmpString
End With
With objNotesField
.AddNewLine (1)
.AppendText " "
.AddNewLine (2)
objNotesStyle.NotesColor = 2
objNotesStyle.Bold = True
objNotesStyle.Italic = True
Call objNotesField.appendstyle(objNotesStyle)
.AppendText "text."
.AddNewLine (1)
objNotesStyle.NotesColor = 0
objNotesStyle.Bold = False
objNotesStyle.Italic = False
Call objNotesField.appendstyle(objNotesStyle)
.AddNewLine (1)
End With
With objNotesField
.AppendText "Kind Regards,"
.AddNewLine (2)
objNotesStyle.Italic = True
objNotesStyle.NotesColor = 14
Call objNotesField.appendstyle(objNotesStyle)
.AppendText " "
.AddNewLine (1)
.AppendText " "
.AddNewLine (1)
.AppendText " "
.AddNewLine (1)
.AppendText " "
.AddNewLine (1)
.AppendText "Call: "
.AddNewLine (1)
.AppendText "Email: "
.AddNewLine (1)
.AppendText "website"
.AddNewLine (1)
End With
' Depending on what the flag is, either send or save to drafts
If saveSendFlag = 1 Then
' Send the email & close down the connection with Lotus
objNotesDocument.SaveMessageOnSend = True
objNotesDocument.Send (0)
Else
' Save the email as draft & close down the connection with Lotus
Call objNotesDocument.Save(True, False)
objNotesDocument.RemoveItem ("DeliveredDate")
Call objNotesDocument.Save(True, False)
End If
' Release storage
Set objNotesSession = Nothing
Set bjNotesSession = Nothing
Set objNotesMailFile = Nothing
Set objNotesDocument = Nothing
Set objNotesField = Nothing
Set objNotesStyle = Nothing
End If
' Next mover
currRow = currRow + 1
Wend
' Hide the status dialog and delete it (remove reference to it)
statusDialog.Hide
MsgBox "The e-mail generator script has run sucessfully" & vbCrLf & _
"" & vbCrLf & _
"In total: " & vbCrLf & _
"Leavers processed = " & statusDialog.Label2.Caption & vbCrLf & _
"Leavers with no e-mail created = " & numNonPermUsers & vbCrLf & _
"Total e-mails created = " & (statusDialog.Label2.Caption - numNonPermUsers), vbExclamation, "Completed"
' After processed all the movers, notify the user if any movers had no permissions and no emails sent for them
If nonPermUsers <> "" Then
Dim finalDialog As UserForm2
Set finalDialog = New UserForm2
' Set the text on the form
finalDialog.TextBox1.Text = nonPermUsers
' Make the form visible
finalDialog.Show
End If
Exit Sub
' Error handling code designed to warn if any errors occurred during attempt to send email
SendMailError:
Msg = "Is Lotus Running? - Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End Sub
