Contact US

Log In

Come Join Us!

Are you an
Engineering professional?
Join Eng-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Eng-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Students Click Here

Project 2010: VBA Assistance Needed

Project 2010: VBA Assistance Needed

Project 2010: VBA Assistance Needed


I have the following code that works great as long as the "Resource Names" field isn't Null.


Sub sendOutlookTaskEmails()

' MS Project 2010 or above
' MS Outlook 2003 or above
' 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.
' 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>" & _
    '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
            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)
            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>" & _
    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
        .HTMLBody = sHTML_Body
    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
    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.

CODE -->

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.


Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

Red Flag Submitted

Thank you for helping keep Eng-Tips Forums free from inappropriate posts.
The Eng-Tips staff will check this out and take appropriate action.

Reply To This Thread

Posting in the Eng-Tips forums is a member-only feature.

Click Here to join Eng-Tips and talk with other members! Already a Member? Login


Low-Volume Rapid Injection Molding With 3D Printed Molds
Learn methods and guidelines for using stereolithography (SLA) 3D printed molds in the injection molding process to lower costs and lead time. Discover how this hybrid manufacturing process enables on-demand mold fabrication to quickly produce small batches of thermoplastic parts. Download Now
Design for Additive Manufacturing (DfAM)
Examine how the principles of DfAM upend many of the long-standing rules around manufacturability - allowing engineers and designers to place a part’s function at the center of their design considerations. Download Now
Taking Control of Engineering Documents
This ebook covers tips for creating and managing workflows, security best practices and protection of intellectual property, Cloud vs. on-premise software solutions, CAD file management, compliance, and more. Download Now

Close Box

Join Eng-Tips® Today!

Join your peers on the Internet's largest technical engineering professional community.
It's easy to join and it's free.

Here's Why Members Love Eng-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close