Hi,
got the following script which will generate a load of draft emails, from a list i have.
However i want some parts of the emails i create to be in bold (templateHeader for example)
anyone know how to do this?
got the following script which will generate a load of draft emails, from a list i have.
However i want some parts of the emails i create to be in bold (templateHeader for example)
anyone know how to do this?
Code:
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Sub MoversReports()
' 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, EMailBCCTo, EMailSendTo, templateSubject, templateHeader, templateFooter, templateAttach, currRow, reportRow, reqRow
Dim reportDate, sender, userGBID, userName, oldLineMgr, newLineMgr, userEmail, oldLineMgrEmail, newLineMgrEmail, transferDate, foundPerm, endedPerm, tmpString, linesCnt, saveSendFlag
Dim nonPermUsers, numNonPermUsers, reportSheetName, reportSheetRow
'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
'EMailBCCTo = ""
'EMailCCTo = dataSheet.Cells(5, 12).Value
templateSubject = dataSheet.Cells(5, 13).Value
templateHeader = dataSheet.Cells(5, 14).Value
templateFooter = dataSheet.Cells(5, 15).Value
templateAttach = dataSheet.Cells(5, 16).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
' 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 & ","
' 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
' 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)
' 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
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
.appendtext tmpString
.ADDNEWLINE 1
End With
End If
reportRow = reportRow + 1
End If
Wend
' Add footer
tmpString = Replace(templateFooter, "<USERNAME>", userName)
tmpString = Replace(tmpString, "<USERGBID>", userGBID)
With objNotesField
.appendtext tmpString
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
End If
' Next mover
currRow = currRow + 1
Wend
' Hide the status dialog and delete it (remove reference to it)
statusDialog.Hide
' 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