Project 2010: VBA Assistance Needed

[eckert1961]

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