none
VBA Assistance Needed

    Pertanyaan

  • 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

    Sabtu, 03 Mei 2014 20.50

Jawaban

  • Chris,

    Try this and see if it does what you need. I added the functionality I think you want and made some other tweaks but I did not optimize it. If this answers your question please mark it as answered.

    John

    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


    Senin, 05 Mei 2014 20.05
  • Chris,

    I received your file and was able to replicate the duplicate email address issue you reported. I fixed that issue along with some others I discovered during troubleshoot and then optimized the code for faster, better performance. You should have the updated macro in your possession now.

    Hope this helps.

    John

    • Ditandai sebagai Jawaban oleh Chris Eckert Senin, 12 Mei 2014 00.22
    Minggu, 11 Mei 2014 23.49
  • Chris,

    Something like this should point you in the right direction. I used a simple file with one summary line and 5 subtasks. The summary was "marked" and "Mark" is the name of my filter for the Marked field. Of the subtasks only two have resources assigned. For testing I printed the resource email addresses into the immediate window.

            

    Sub getemail()
    Dim Email() as String
    Dim t As Task
    Dim a As Assignment
    Dim ch As Task
    FilterApply Name:="Mark"
    SelectTaskColumn
    ReDim Email(ActiveProject.Resources.Count)
    i = 1
    For Each t In ActiveSelection.Tasks
        '[statements to grab the data for the summary line]
        'now get the email addresses for all subtask assignments
        For Each ch In t.OutlineChildren
            For Each a In ch.Assignments
                Email(i) = ActiveProject.Resources(a.ResourceName).EMailAddress
                Debug.Print Email(i)
                i = i + 1
            Next a
        Next ch
    Next t

    End Sub

    John

    Minggu, 04 Mei 2014 20.57

Semua Balasan

  • Chris,

    Sorry but I don't get an error. I set up a simple 5 task file. Task 2 has a resource assigned, task 3 does not. Both tasks have the Marked field set to "yes". If I understand what you describe as the cause of error, task 3 should cause the error because there is a blank in the Resource Names field, but everything works fine.

    The code looks like it could use some refining. Normally I like to write code that uses background processing, but since this macro requires the user to set the Marked field, running the macro using foreground processing will allow to take advantage of more efficient code in this case. For example, instead of looping through all tasks, you might consider applying a filter for the Marked field. Then select that set (e.g. SelectAll), and loop though it using:

    For Each t in ActiveSelection.Tasks

    I'd also just do a count of the selected tasks (i.e. ActiveSelection.Tasks.Count) and ReDim all the arrays with that number before even starting the loop. Then there won't be a need to waste time in the loop to ReDim each array.

    At first I thought there might be an error with the duration statement since the raw value is divided by 8. All Project time data is stored in minutes so normally you would divide a duration value in VBA by 480, which is the number of minutes in a standard default 8 hour day. However, when the values appeared correctly in Outlook I looked further and saw that the additional division by 60 is carried out when the duration array is dumped into Outlook.

    There is an "If" statement in the loop that looks like it is trying to set the arrResources(x) to blank if the Resource Names field is blank. First, this loop is not necessary. If the Resource Names field is empty, the array element will also be empty. However, the "If" statement does NOT set the array element to an empty value (i.e. ""), it actually sets it to a space (i.e. " "). Maybe that's the intent, I don't know, but just for interest I tweaked the "If" statement to actually put a blank in that array element and the macro ran fine and produced the same Outlook display.

    Those are just a few of the things I noticed.

    With regard to your getting a runtime error, do You have SP2 installed for Project 2010? If not, install it, it fixes some issues related to VBA. You should also install the 2013 cumulative update as that came after SP2 and also has some VBA fixes.

    Hope this helps.

    John

    Minggu, 04 Mei 2014 02.59
  • Hi John,

    Thanks so much for the reply. To clarify, I only get the error if I set the Marked field to Yes for rows that don't have a resource name. This is the case for all top level tasks. In your test file, if you only set the Marked field to Yes for task 3 you will get the error that I noted.

    Regarding the tweak you made to the If statement. Can you show me the syntax that you used?

    I'm interested to hear if you see the error and what the work around is.

    Regards,
    Chris


    Minggu, 04 Mei 2014 03.17
  • Chris,

    Okay, now I get the error. The error occurs in this case because the array "arrEmails" has been effectively made a non-array by the ReDim statement in this following loop. Then when the code later tries to use that array, the error occurs.

                   

    For z = 1 To t.Resources.Count
    ReDim Preserve arrEmails(1 To totalCountEmails) As String  'totalCountEmails is zero!
                    growingEmailCount = growingEmailCount + 1
                    arrEmails(growingEmailCount) = t.Resources(z).EMailAddress
                Next z

    The workaround? I'd have to study the code in more detail but I do notice that the macro re-dimensions the arrEmails array multiple times. That's extra processing that isn't necessary and is at the heart of why the error occurs. As I indicated in my first response, I'd filter the file for the Marked field at the beginning of the macro, then re-dimension all the arrays based on the count of the filter selection. Then go use those arrays. Yes, in some cases the arrays may not be fully utilized, (i.e. contain null elements), but the code will also never hit a subscript out-of-range error.

    My "tweak" to the "If" statement is real simple, delete it because it isn't needed. I'd simply use:

    arrResources(x) = t.ResourceNames

    John

    Minggu, 04 Mei 2014 16.03
  • Thanks John,

    I filtered for the Marked field and it definitely speeds up the processing. I also deleted the If statement as you recommended.

    The last issue is to figure out how to generate the email even if the Resource Names field is blank? Any additional recommendations would be appreciated.

    Regards,
    Chris

    Minggu, 04 Mei 2014 17.35
  • Chris,

    Again, I don't totally understand what you are trying to do but, why do you need an email if there is no resource?

    John

    Minggu, 04 Mei 2014 17.45
  • John,

    On occasion I only want to generate an email that contains the Summary Tasks. As an example I have the following.

    Task Name Duration Start Finish Revised Finish Predecessors Resource Names
    Business Requirements - Mobile 23 days Mon 03/03/14 Wed 02/04/14 NA
       Update BRD - Mobile with Multi User changes 6 days Mon 24/03/14 Mon 31/03/14 NA Colleen
       Approval BRD - Mobile 2 days Tue 01/04/14 Wed 02/04/14 NA 49 Lorna,Tom
       Mobile Architectural Definition Document 20 days Mon 03/03/14 Fri 28/03/14 Fri 11/04/14 Tim Janzen,Garth May,Kristine Kozoriz,Michael Madan

    I only want to include the "Business Requirements - Mobile" in the email that I send out to the team to provide a High Level list of tasks that we will be discussing during an upcoming meeting.

    I hope that clarifies what I'm attempting to achieve.

    Regards,
    Chris

    Minggu, 04 Mei 2014 17.56
  • Chris,

    So if I understand correctly, in your example above, you want to export the data from the summary line only, (i.e. "Business Requirements - Mobile ", 23 Days, Mon 03/03/14, etc.), but you want to send that out to each of the resources that are assigned to subtasks under that summary (i.e. Colleen, Lorna, Tom, Tim, Janzen, etc.)? If that is your intent, then which tasks are marked, since that's the filter you are now using? If only the summary task is marked, then you could cycle through the assignments of each child task of the summary, grab the resource name and go get their email. That would be a combination of foreground processing to pick up the marked tasks and background processing to get the email addresses.

    John

    Minggu, 04 Mei 2014 18.39
  • John,

    In this example I would only Mark the Summary Task. How would you code it so that, as you suggest, "cycle through the assignments of each child task of the summary, grab the resource name and go get their email"?

    Chris

    Minggu, 04 Mei 2014 18.52
  • Chris,

    Something like this should point you in the right direction. I used a simple file with one summary line and 5 subtasks. The summary was "marked" and "Mark" is the name of my filter for the Marked field. Of the subtasks only two have resources assigned. For testing I printed the resource email addresses into the immediate window.

            

    Sub getemail()
    Dim Email() as String
    Dim t As Task
    Dim a As Assignment
    Dim ch As Task
    FilterApply Name:="Mark"
    SelectTaskColumn
    ReDim Email(ActiveProject.Resources.Count)
    i = 1
    For Each t In ActiveSelection.Tasks
        '[statements to grab the data for the summary line]
        'now get the email addresses for all subtask assignments
        For Each ch In t.OutlineChildren
            For Each a In ch.Assignments
                Email(i) = ActiveProject.Resources(a.ResourceName).EMailAddress
                Debug.Print Email(i)
                i = i + 1
            Next a
        Next ch
    Next t

    End Sub

    John

    Minggu, 04 Mei 2014 20.57
  • Thanks John,

    This looks promising. I'll incorporate your code into mine and see how it goes.

    I really appreciate your assistance.

    Regards,
    Chris

    Minggu, 04 Mei 2014 21.10
  • John,

    I tested your code and it works great. My challenge is that I do not have a clue how to incorporate it into the sendOutlookTaskEmails() code. Any pointers or outright spoiler would be great.

    Thanks,

    Chris

    Minggu, 04 Mei 2014 21.22
  • Chris,

    Did you write the sendOutlookTaskEmails code or did you get it from someone else?

    I didn't test this in your macro but it looks like the two loops in my code that create the eMails array should replace the statements in your code right after the "capture resource emails". You'll also have to add the dimensions statements for assignments and children to your code.

    John

    Minggu, 04 Mei 2014 23.18
  • Hey John,

    I found the code through a google search. Unfortunately, I am far from being a developer so I am completely lost when it comes to taking your code and dropping it into sendOutlookTaskEmails code.

    I did make the attempt but now the code doesn't work at all. I receive the error "Subscript out of range".

    If you're able to add your code to the macro that would be awesome but if not I do appreciate your assistance.

    Regards,
    Chris

    Senin, 05 Mei 2014 00.56
  • Chris,

    Okay, that's what I figured. The macro is interesting to me, so I'm working on incorporating my code into it. Along the way, I'm tweaking it for better efficiency but it may take me a couple of days as this is not my top priority.

    John

    Senin, 05 Mei 2014 02.31
  • Chris,

    Question. In an earlier response you mentioned that on occasion you will only have summary lines that are marked. Does that mean that sometimes you will only have summary lines with the Marked field "yes" and at other times you will only have subtasks with the marked field "yes", or might you also have a combination (i.e. some summary lines marked and other subtasks that are not part of that summary marked)? I need this to branch the code appropriately.

    John

    Senin, 05 Mei 2014 02.58
  • John,

    I will also have the combination that you outlined.

    Thanks and I'm looking forward to seeing the new and improved version.

    Chris

    Senin, 05 Mei 2014 03.05
  • Chris,

    Try this and see if it does what you need. I added the functionality I think you want and made some other tweaks but I did not optimize it. If this answers your question please mark it as answered.

    John

    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


    Senin, 05 Mei 2014 20.05
  • Hi John,

    This is fantastic. I tried it and it works great but there is one minor item. When the table is generated an additional row is added with a 0 Days duration. When you run the code do you also get that extra row?

    Chris

    Senin, 05 Mei 2014 20.28
  • Chris,

    Well yeah, what do you expect for free? Actually I thought it would be a good exercise for the student. No?

    Okay, I'll fix it, but this is gonna cost you a bundle! 

    See the previous code post, I edited it.

    John

    Senin, 05 Mei 2014 22.08
  • John,

    Regarding my last message about the extra row. I changed the following and it seems to address this, however, I'm not sure if what I did is the correct approach.

     'Create table rows for each task.
        For x = 0 To NumTsk

    Changed to the following.

        For x = 0 To NumTsk - 1

    Other than this item the code works brilliantly. Thank you for taking the time to provide this code.

    Regards,
    Chris

    Senin, 05 Mei 2014 22.10
  • John,

    Considering that you did this for free I have to say you far exceeded my expectations. Thank you for the fix and for the great code.

    Regards,
    Chris


    Senin, 05 Mei 2014 22.15
  • Chris,

    Uh, yeah. I think you kinda missed the point on what [who] actually answered your question (see Julie's suggestion). Nonetheless, you're welcome

    John

    Selasa, 06 Mei 2014 01.23
  • Julie, my apologies for not noticing that you provided the suggestion. Thank you.

    Regards,
    Chris

    Rabu, 07 Mei 2014 22.28
  • Chris,

    I think you can mark more than one response as the answer but if not you can unmark your response as the answer and pick a more appropriate response as the answer.

    Just for reference, those of us who respond to questions on this forum are all volunteers, none of us work for Microsoft. For our time and effort, we are awarded points if our response is the answer or at least helpful to the original poster. What do the points get us? Nothing, other than the recognition that we are helping the user community.

    John

    Rabu, 07 Mei 2014 23.23
  • Chris,

    Sorry no offense I hope - I have unmarked yours as the answer and marked John's code as the answer.  You can also click the up arrow under the checkmark for the answered post to "vote up" John's answer as being helpful to give him some extra "kudos".

    John - thank you for going above and beyond!!

    Kamis, 08 Mei 2014 18.57
    Moderator
  • Julie,

    No offense taken as it was the right thing to do. I also voted up John's answer.

    I do have 1 item regarding the code that I identified. I discovered if I select multiple summary & child tasks where the resource is the same then I get duplicate emails entered in the To: line. The recipient only receives 1 email so it's really just a minor issue but I'm curious how this should be addressed.

    Regards,
    Chris

    Kamis, 08 Mei 2014 22.30
  • Chris,

    You do realize that solving this little issue will require you to cast more votes, and maybe even wiring some funds to my offshore account, right?  :-)

    Could you give me an example what you mean by the multi-select? I expanded my test file to have 4 summary lines. I marked the first two summary lines and then marked individual tasks under the other two summary lines. I ran the macro and did not see an duplication of e-mail addresses in the Outlook graphic.

    John

    P.S. my level of levity exponentially increases as the day wears on.

    Jumat, 09 Mei 2014 02.36
  • John,

    I am happy to provide many votes. Here is a screenshot of what I'm encountering. All of the noted IDs are child tasks. I just noted that If I only select summary tasks than no duplicate emails are entered in the To line.

    Jumat, 09 Mei 2014 14.47
  • Chris,

    Okay I see the duplication in the Outlook output but what I really need to get is a more detailed example of the Project file such that I can see the problem when I run it and do some testing to determine what is going on. At this point it might be easier if you could e-mail me your file, or at least a mockup that I can use to see the issue, if your live file is proprietary. My e-mail address is below, it is encoded to prevent spam. I will ask some questions. Please note: if your file is larger than 1M do NOT e-mail it, we'll figure out something else.

    John

    jensenljatatfastmaildotdotfm

    (remove obvious redundancies and the 7th character is a letter) 

    Jumat, 09 Mei 2014 16.03
  • John,

    Unfortunately, my file is over 1MB. Let me know what other option you have and I can forward you my mpp.

    Chris

    Jumat, 09 Mei 2014 17.42
  • Chris,

    I really don't need the whole file, only enough so I can see the issue. Try deleting most of it and save as a new file. Make sure you can still show the issue and that the new reduced file is 1M or less, then zip it and send.

    If for some reason the above doesn't work, do you have a website you can post it to such that I can retrieve it? The size limit is due to my mail server, not my broadband connection.

    John

    Jumat, 09 Mei 2014 18.19
  • John,

    I actually don't have any way to zip a file at work and our IS locks down our laptops to the point that I cannot install anything. Once I get home, I will send you the mpp.

    Regards,
    Chris

    Jumat, 09 Mei 2014 18.37
  • John,

    I just emailed the mpp. Let me know if you don't receive it and I will resend.

    Regards,
    Chris

    Jumat, 09 Mei 2014 22.22
  • Chris,

    I received your file and was able to replicate the duplicate email address issue you reported. I fixed that issue along with some others I discovered during troubleshoot and then optimized the code for faster, better performance. You should have the updated macro in your possession now.

    Hope this helps.

    John

    • Ditandai sebagai Jawaban oleh Chris Eckert Senin, 12 Mei 2014 00.22
    Minggu, 11 Mei 2014 23.49
  • Is there a way to make this run automatically when something is marked 100% Complete?
    Jumat, 22 Juni 2018 17.36
  • Filo,

    Yes, probably so but it would require an Event triggered macro that tests for a change Event on the % Complete field.

    John

    Sabtu, 23 Juni 2018 16.40
  • Hi John, This code is fantastic.

    I have also setup some graphical indicators in the status column but my code only puts the number from my formula in the email table rather than the actual graphical indicator. I'm wondering if you can please tell me how to capture graphical indicators and put them into the email table?

    Thank you.

    Senin, 09 Juli 2018 02.14
  • NVMEM8,

    Sorry I can't and I believe graphical indicators are one of those things in Project that is internally created and not accessible for copy or export. However maybe someone else knows a trick and will jump into this thread.

    John

    Senin, 09 Juli 2018 15.29
  • NVMEM8,

    John is right, as usual.  Like many formatting/display properties in Project, the graphical indicators are not readable using vba.  So the idea of "capturing" existing graphical indicators for inserting into a table is a non-starter.  You CAN use vba to create entirely new graphical indicators using the CustomFieldIndicators, CustomFieldIndicatorAdd, and CustomFieldPropoertiesEx methods.  Recording a macro of your creating new graphical indicators would be a good start.  Good luck, tom  

    Senin, 09 Juli 2018 16.32
  • Thanks for the information and fast reply.

    I might verbalize the graphical indicators in another column and use that instead.

    Thanks again John & Tom.

    Senin, 09 Juli 2018 23.56
  • NVMEM8,

    You're welcome and thanks for the feedback.

    John

    Selasa, 10 Juli 2018 01.55