Hello,
I have the following code that works great as long as the "Resource Names" field isn't Null.
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.
'
' 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
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error GoTo errHandler
'Count the number of marked tasks. If no tasks are selected then exit the procedure.
Dim t As Task
For Each t In ActiveProject.Tasks
Dim countOfTasks As Long
If t.Marked = True Then
countOfTasks = countOfTasks + 1
End If
Next t
If countOfTasks = 0 Then
MsgBox "No tasks were selected."
Exit Sub
End If
Dim projectName As String
Dim sEmail As String
Dim sUniqueID As String
Dim sToAddress As String
Dim sCCAddress As String
Dim sInstructions As String
Dim sHTML_Body As String
Dim sHTML_tableHeader As String
Dim sHTML_tableFooter As String
Dim sHTML_tableBody As String
Dim taskCellsInteriorColor As String
Dim headerCellsInteriorColor As String
Dim inputCellsInteriorColor As String
Dim fontColor As String
Dim fontFamily As String
Dim fontSize As String
Dim styleHeader As String
Dim styleHeaderCols As String
Dim styleRowCells As String
Dim styleInputCells As String
'Customizable settings.
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>"
'Create arrays to capture task details.
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
'Capture task details.
Dim x As Long
x = 1
For Each t In ActiveProject.Tasks
If t.Marked = True Then
ReDim Preserve arrTaskID(1 To x) As String
ReDim Preserve arrTaskName(1 To x) As String
ReDim Preserve arrTaskDuration(1 To x) As Long
ReDim Preserve arrStart(1 To x) As String
ReDim Preserve arrEnd(1 To x) As String
ReDim Preserve arrResources(1 To x) As String
arrTaskID(x) = t.UniqueID
arrTaskName(x) = t.Name
arrTaskDuration(x) = t.Duration / 8
arrStart(x) = Format(t.ScheduledStart, "dd-mmm-yy")
arrEnd(x) = Format(t.ScheduledFinish, "dd-mmm-yy")
If t.ResourceNames <> "" Then
arrResources(x) = t.ResourceNames
Else
arrResources(x) = " "
End If
'Capture resource emails.
Dim totalCountEmails, z, growingEmailCount As Integer
totalCountEmails = totalCountEmails + t.Resources.Count
'If t.Resources.Count > 1 Then
For z = 1 To t.Resources.Count
ReDim Preserve arrEmails(1 To totalCountEmails) As String
growingEmailCount = growingEmailCount + 1
arrEmails(growingEmailCount) = t.Resources(z).EMailAddress
Next z
'End If
x = x + 1
End If
Next t
'Remove duplicate emails.
Dim myCollection As New Collection
Dim temp As Variant
On Error Resume Next
For Each temp In arrEmails
myCollection.Add Item:=temp, key:=temp
Next temp
On Error GoTo 0
'If Not IsNull(arrEmails()) Then
ReDim arrEmails(1 To myCollection.Count)
For temp = 1 To myCollection.Count
arrEmails(temp) = myCollection(temp)
Next temp
'List all of the email addresses together.
For i = LBound(arrEmails) To UBound(arrEmails)
sEmail = sEmail + ";" + arrEmails(i)
Next i
sToAddress = sEmail
'End If
'List the Unique IDs together.
For i = LBound(arrTaskID) To UBound(arrTaskID)
If UBound(arrTaskID) = 1 Then
sUniqueID = arrTaskID(i)
Else
sUniqueID = sUniqueID + arrTaskID(i) + "; "
End If
Next i
'Remove last semi-colon from sUniqueID.
If UBound(arrTaskID) > 1 Then
sUniqueID = Left(sUniqueID, Len(sUniqueID) - 2)
End If
'Create table rows for each task.
For x = 1 To countOfTasks
sHTML_tableBody = sHTML_tableBody + _"<tr>" & _"<td style=" & styleRowCells & arrTaskID(x) & "</td>" & _"<td style=" & styleRowCells & arrTaskName(x) & "</td>" & _"<td style=" & styleRowCells & arrTaskDuration(x) / 60 & " 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.
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
'Unmark the tasks.
For Each t In ActiveProject.Tasks
If t.Marked = True Then
t.Marked = False
End If
Next t
Exit Sub
errHandler:
MsgBox "An error has occurred. Please ensure you have MS Outlook installed."
End Sub If the "Resource Names" field is Null then I get the following error.
Run-time error '9':
Subscript out of range
When I click on debug, the following line of code is highlighted.
ReDim arrEmails(1 To myCollection.Count)
What I want to happen, if the "Resource Names" field is Null, is to still create the email.
Please let me know if you need any additional clarification.
Regards,
Chris