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.
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





Reply With Quote