Send email notifications code
I have found some code that makes MS Project to send emails through Outlook to the assigned resources to a selected task. Everything works fine except I get an "Runtime error 9. Subscript out of range." when trying to remove duplicate emails in an array. I am not an expert in VBA so I'm turning to you guys.
The method is simple. I have few tasks with assigned resources to them. I have a column named "Marked". The scripts checks if there are any tasks marked with "Yes" and sends an email to the assigned resource to those tasks. I get the error in the snippet where the code is purging the array of duplicate emails(arrEmails gets the error). If I delete this part of the code everything works fine except the array is concatenating only the first email address it encounters. I'm not sure if the problem is with the array dimensions or something else.
Code:
Sub sendOutlookTaskEmails()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' REQUIREMENTS
' MS Project 2010 or above
' MS Outlook 2003 or above
'
' SUMMARY
' This macro enables users to select tasks in MS Project and populate Outlook email
' messages with information contained in each task such as Task Name, Task ID,
' Resources, etc.
' AUTHOR: Unknown
' Modified by John 5/5/14
'
' HOW TO USE
' 1. Select a task(s) by changing the value of the cell in the "Marked" column
' (If the Marked column is not visible then right-click on any header and
' click "Insert Column" and select "Marked"
' 2. Click "Send Email" button in "Custom Tools" in "Tasks" ribbon
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim arrTaskID() As String
Dim arrTaskName() As String
Dim arrTaskDuration() As Long
Dim arrStart() As String
Dim arrEnd() As String
Dim arrResources() As String
Dim arrEmails() As String
Dim t As Task
Dim ass As Assignment
Dim ch As Task
Dim x As Integer, i As Integer, j As Integer, k As Integer, TotEmails As Integer
Dim MPD As Single
Dim NumTsk As Integer, NumRes As Integer
Dim projectName As String, sEmail As String, sUniqueID As String
Dim sToAddress As String, sCCAddress As String, sInstructions As String
Dim sHTML_Body As String, sHTML_tableHeader As String, sHTML_tableFooter As String
Dim sHTML_tableBody As String
Dim taskCellsInteriorColor As String, headerCellsInteriorColor As String
Dim inputCellsInteriorColor As String
Dim fontColor As String, fontFamily As String, fontSize As String
Dim styleHeader As String, styleHeaderCols As String, styleRowCells As String, styleInputCells As String
'create simple filter to select only those tasks with "yes" in Marked field
FilterEdit Name:="Mark", taskfilter:=True, create:=True, overwriteexisting:=True, _
FieldName:="Marked", Test:="equals", Value:="yes", ShowInMenu:=False
FilterApply Name:="Mark"
SelectTaskColumn
'find max size for arrays. Values are overkill but doing it this way
' eliminates the need to continually re-dimension arrays
On Error Resume Next
NumTsk = ActiveSelection.Tasks.Count
If Err > 0 Then
MsgBox "No tasks selected"
FilterApply Name:="all tasks"
Exit Sub
End If
On Error GoTo 0
NumRes = ActiveProject.Resources.Count * NumTsk
If NumTsk = 0 Then
MsgBox "No tasks selected"
Exit Sub
Else
ReDim arrTaskID(NumTsk), arrTaskName(NumTsk), arrTaskDuration(NumTsk)
ReDim arrStart(NumTsk), arrEnd(NumTsk)
ReDim arrResources(NumRes), arrEmails(NumRes)
End If
'Customizable settings for Outlook
projectName = "Small Business Online Banking"
sInstructions = "Please update the Status field for each task as either C = Complete or N = Not Complete. Please also note the duration of the task and any additional comments."
sCCAddress = ""
'Colors are in hexadecimal format.
headerCellsInteriorColor = "#D9D9D9"
taskCellsInteriorColor = "#ffffff"
inputCellsInteriorColor = "#F6F6F6"
borderColor = "#848484"
fontColor = "#0B0B0B"
fontFamily = "Arial"
fontSize = "13"
'CSS styles for the HTML table.
styleHeader = "'background-color:" & taskCellsInteriorColor & ";border: 1px solid " & borderColor & "; border-collapse: collapse; font-family:" & fontFamily & "; font-size:20;'"
styleHeaderCols = "'background-color:" & headerCellsInteriorColor & ";border: 1px solid " & borderColor & "; border-collapse: collapse; font-family:" & fontFamily & "; font-size:" & fontSize & ";color:" & fontColor & "'"
styleRowCells = "'background-color:" & taskCellsInteriorColor & ";border: 1px solid " & borderColor & "; border-collapse: collapse; font-family:" & fontFamily & "; font-size:" & fontSize & ";'>"
styleInputCells = "'background-color:" & inputCellsInteriorColor & ";border: 1px solid " & borderColor & "; border-collapse: collapse; font-family:" & fontFamily & "; font-size:" & fontSize & ";'>"
'Create the HTML table header and header fields.
sHTML_tableHeader = _
"<table style='border: 1px solid " & borderColor & ";' cellpadding=8>" & _
"<tr>" & _
"<td colspan=9 style=" & styleHeader & ">" & projectName & " Tasks </td></tr>" & _
"<tr>" & _
"<th style=" & styleHeaderCols & ">Unique ID</td>" & _
"<th style=" & styleHeaderCols & ">Task Name</td>" & _
"<th style=" & styleHeaderCols & ">Duration</td>" & _
"<th style=" & styleHeaderCols & ">Start</td>" & _
"<th style=" & styleHeaderCols & ">End</td>" & _
"<th style=" & styleHeaderCols & ">Resources</td>" & _
"<th style=" & styleHeaderCols & ">Status</td>" & _
"<th style=" & styleHeaderCols & ">Actual Duration</td>" & _
"<th style=" & styleHeaderCols & ">Comments</td>" & _
"</tr>"
'Create the HTML table footer.
sHTML_tableFooter = _
"<tr>" & _
"<td colspan=9 style=" & styleHeaderCols & ">" & sInstructions & "</td></tr>"
'Capture task details.
x = 0: i = 0
MPD = ActiveProject.HoursPerDay * 60
For Each t In ActiveSelection.Tasks
arrTaskID(x) = t.UniqueID
arrTaskName(x) = t.Name
arrTaskDuration(x) = t.Duration / MPD
arrStart(x) = Format(t.ScheduledStart, "dd-mmm-yy")
arrEnd(x) = Format(t.ScheduledFinish, "dd-mmm-yy")
arrResources(x) = t.ResourceNames
If t.Summary = True Then
For Each ch In t.OutlineChildren
For Each ass In ch.Assignments
arrEmails(i) = ActiveProject.Resources(ass.ResourceName).EMailAddress
i = i + 1
Next ass
Next ch
Else
For Each ass In t.Assignments
arrEmails(i) = ActiveProject.Resources(ass.ResourceName).EMailAddress
i = i + 1
Next ass
End If
x = x + 1
Next t
'purge email array of duplicate addresses and re-build array
k = 0
For i = 0 To NumRes
For j = i + 1 To 9
If arrEmails(i) = arrEmails(j) Then arrEmails(j) = ""
Next j
If arrEmails(i) <> "" Then
arrEmails(k) = arrEmails(i)
k = k + 1
End If
Next i
TotEmails = k - 1
'concatenate a string of all email addresses
sEmail = arrEmails(0) 'seed string with first element
For i = 1 To TotEmails
sEmail = sEmail + ";" + arrEmails(i)
Next i
sToAddress = sEmail
'concatenate the Unique IDs together
sUniqueID = arrTaskID(0)
For i = 1 To UBound(arrTaskID)
sUniqueID = sUniqueID + "; " + arrTaskID(i)
Next i
'Create table rows for each task.
For x = 0 To NumTsk - 1
sHTML_tableBody = sHTML_tableBody + _
"<tr>" & _
"<td style=" & styleRowCells & arrTaskID(x) & "</td>" & _
"<td style=" & styleRowCells & arrTaskName(x) & "</td>" & _
"<td style=" & styleRowCells & arrTaskDuration(x) & " Days</td>" & _
"<td style=" & styleRowCells & arrStart(x) & "</td>" & _
"<td style=" & styleRowCells & arrEnd(x) & "</td>" & _
"<td style=" & styleRowCells & arrResources(x) & "</td>" & _
"<td style=" & styleInputCells & "</td>" & _
"<td style=" & styleInputCells & "</td>" & _
"<td style=" & styleInputCells & "</td>" & _
"</tr>"
Next x
'Combine the HTML table header, body, and footer.
sHTML_Body = sHTML_tableHeader + sHTML_tableBody + sHTML_tableFooter + "</table>"
'Open Outlook and begin building emails.
On Error GoTo errHandler
Set OutLookOpen = CreateObject("Outlook.application")
'Create Outlook Email Message
Dim objEmail As Object
Dim objOutlook As Object
'Open Outlook and begin building emails.
Set objEmail = OutLookOpen.CreateItem(olMailItem)
With objEmail
.To = sToAddress
.CC = sCCAddress
.Subject = projectName & " Tasks - Unique Task ID(s): " & sUniqueID
.Display
.HTMLBody = sHTML_Body
.Display
End With
'Clean up and close
For Each t In ActiveSelection.Tasks
t.Marked = False
Next t
FilterApply Name:="all tasks"
Exit Sub
errHandler:
MsgBox "An error has occurred. Please ensure you have MS Outlook installed."
End Sub
