To quote from my original post "I've texted and it's not a problem with the html body text which I have removed for brevity reasons.". I already did that.
If you're interested in the full text it's here:
Code:
Private Sub cmdEmailReviewers_Click()
Dim reviewList As DAO.Recordset
Dim Plan As DAO.Recordset
Dim oApp As Outlook.Application
Dim oMail As MailItem
Dim toList As String
Dim ccList As String
Dim oText As String
' First check that all the reviewers have been specified. That is that there
' are no blank gaps in the main reviewer column
Set reviewList = CurrentDb.OpenRecordset("SELECT * FROM tblIPScomments WHERE [Plan]=" & Me.txtHiddenID & " AND isnull([MainReviewer])")
' If all reviewers have been specified this should return no records
If Not (reviewList.BOF And reviewList.EOF) Then
oText = "You must specify at least a primary reviewer for each stage of the review loop. "
oText = oText & "Specification of a backup reviewer is optional. Please do this now and try again."
MsgBox oText, vbOKOnly, "Missing Info"
Exit Sub
End If
' Reset the reviwelist to pick up all reviewers for this plan
' At this stage we shouldn't have already sent any emails, but to be safe that we do not
' accidently allow people to spam reviewers with messages, also ensure that the email sent date is blank
' We set the EmailSent date when we first send out request for review emails.
' Not we also need to get the plan details to populate the email with useful information
Set reviewList = CurrentDb.OpenRecordset("SELECT * FROM tblIPScomments WHERE [Plan]=" & Me.txtHiddenID & " AND isnull([EmailSent])")
Set Plan = CurrentDb.OpenRecordset("SELECT * FROM tblIPS WHERE [ID]=" & Me.txtHiddenID)
Set oApp = CreateObject("Outlook.Application")
' Loop through the recordset and email the reviewers about their responsibilities
If reviewList.BOF And reviewList.EOF Then
' Request for review emails already sent, inform the user and exit
oText = "Request for review emails have already been sent for this plan."
MsgBox oText, vbOKOnly, "Duplicated Action"
Exit Sub
End If
reviewList.MoveFirst
Do Until reviewList.EOF
' First process any Main reviewers. We have already checked that these are always specified
' EMAIL oText
' Line 1: Warning that this is an automated email and not to reply to it. This is always the same
oText = "<font color='red'>NOTE: THIS IS AN AUTOMATED EMAIL FROM THE CONFIGURATION MANAGEMENT DATABASE.</font><br><br>"
' Line 2 - Opening
oText = oText & "Dear " & DLookup("[FirstName]", "tblUsers", "[ID]=" & reviewList("MainReviewer")) & ",<br><br>"
' oText ongoing. Explain the situation
oText = oText & "A new IPS process plan is ready for review. You have been specified as the primary " & reviewList("ReviewerType") & " reviewer for this plan.<br><br>"
oText = oText & "Plan Details: <br>"
oText = oText & "<ul><li>Plan Title: " & Plan("Title") & "</li>"
oText = oText & "<li>Plan Number: " & Plan("WorkPlan") & "</li>"
oText = oText & "<li>Review Due Date: " & reviewList("DueDate") & "</li>"
oText = oText & "<li>Plan Directory: <a href='" & Plan("Dir") & "'>Hyperlink to directory</a></li></ul><br>"
oText = oText & "If the plan PDF is not in the directory, please contact the author, "
oText = oText & DLookup("[FirstName]", "tblUsers", "[ID]=" & Plan("PlanOwner")) & " "
oText = oText & DLookup("[LastName]", "tblUsers", "[ID]=" & Plan("PlanOwner")) & ", to obtain a copy.<br><br>"
' Explain who the backup reviewer is if there is one.
If Not IsNull(reviewList("BackupReviewer")) Then
oText = oText & "If you are unable to complete this review in the allotted time, the backup reviewer is specified as "
oText = oText & DLookup("[FirstName]", "tblUsers", "[ID]=" & reviewList("BackupReviewer")) & " "
oText = oText & DLookup("[LastName]", "tblUsers", "[ID]=" & reviewList("BackupReviewer"))
oText = oText & ". Please contact them to ensure the review is completed.<br><br>"
End If
' Tell the user what to do with their review comments
oText = oText & "Once the review is complete, please "
oText = oText & "log into the <a href='C:\ProgramData\Trusted VBA\ConfigurationManagementDatabase.accde'>Configuration Management Database</a> to mark your comments as complete and "
oText = oText & "save your marked up PDFs in the directory above.<br><br> "
oText = oText & "You can mark comments as complete through the [Update IPS Work Order or Work Plan] option on the IPS Functionality tab of the dashboard. "
oText = oText & "Failure to do so will result in automatic reminder emails and potential delays to the project.<br><br>"
' Inform the person in cc that they are the backup reviewer
oText = oText & "<font color='blue'>If you are in cc on this email then you have been specified as the backup reviewer. Please check if you are required with the primary reviewer</font><br><br>"
' Add any special notes if there are any
If Not IsNull(Me.txtNotes) Then
oText = oText & "<b>Special Notes</b><br>"
oText = oText & "<font color='" & Me.cboColour & "'>" & Me.txtNotes & "</font><br><br>"
End If
' Sign Off
oText = oText & "Sent on behalf of " & DLookup("[FirstName]", "tblUsers", "[ID]=" & Plan("PlanOwner")) & " " & DLookup("[LastName]", "tblUsers", "[ID]=" & Plan("PlanOwner"))
' END EMAIL oText
'Send the email
Set oMail = oApp.CreateItem(olMailItem)
toList = DLookup("[email]", "tblUsers", "[ID]=" & reviewList("MainReviewer"))
If Not IsNull(reviewList("BackupReviewer")) Then
ccList = DLookup("[email]", "tblUsers", "[ID]=" & reviewList("BackupReviewer"))
Else
ccList = ""
End If
'On Error Resume Next
With oMail
.To = toList
.cc = ccList
.BCC = ""
.subject = "Please Review IPS Plan " & Plan("WorkPlan") & " by " & reviewList("DueDate")
' If High Urgency is set, send as important
If Me.chkUrgency Then .Importance = olImportanceHigh
.HTMLBody = oText
.Display
End With
On Error GoTo 0
' Mark the email as having been sent
reviewList.Edit
reviewList("EmailSent") = Now
reviewList.Update
' Move to the next reviewer
reviewList.MoveNext
Loop
MsgBox "Please send the emails that have appeared on your screen.", vbOKOnly, "Manual action required"
Set oMail = Nothing
Set oApp = Nothing
' If there are updated notes since the plan was originally added, save these to the database now
If Me.cmdEdit.Caption = "Save Notes" Then
Set Plan = CurrentDb.OpenRecordset("SELECT * FROM tblIPS WHERE [ID]=" & Me.txtHiddenID)
Plan.Edit
Plan("Notes") = Me.txtNotes
Plan.Update
Plan.Close
Set Plan = Nothing
Me.cmdEdit.Caption = "Edit Notes"
End If
' Inform the user that emails have been sent
MsgBox "Review request emails sent for this plan.", vbOKOnly, "Complete"