none
Create and Send Individual Resource Task Emails RRS feed

  • Question

  • Hi All

    I have a piece of code kindly donated from one of our members (name not known so I cant give the credit for it) that creates a single email detailing all tasks for all resources.  What I am looking to do is to be able to create a single email for each resource for their activities.  I am struggling with modifying this code so any help would be appreciated.  The code is as follows;

    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 = ActiveProject.Name
        sInstructions = "Please update the Percentage complete field for each task.  Please also make any relevant 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 & ">Percentage Complete</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_tableFooter + sHTML_tableBody + "</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

    Thanks in anticipation of any help.

    Kind regards

    Tony


    TKHussar

    Monday, April 23, 2018 8:26 AM

Answers

  • Thanks Rene. Clearly I posted it on the wrong page. I will check Rod's book and repost if I am still struggling.

    Kind regards 

    Tony


    TKHussar

    • Marked as answer by TKHussar Wednesday, April 25, 2018 7:59 AM
    Wednesday, April 25, 2018 7:59 AM

All replies

  • Hello Tony. Just a quick question.

    You are posting this in "Project Server" forum so I assume that you are using Project Server, am I correct?

    If yes, then Project Server sends just one email to the resource when first publishing or changing an assignment. I believe that would solve your need.

    If you are using only Project Pro, Rod Gill has the bible for VBA programming and I believe he has something in his book about this requirement.


    Rene Alvarez

    Tuesday, April 24, 2018 11:40 PM
  • Thanks Rene. Clearly I posted it on the wrong page. I will check Rod's book and repost if I am still struggling.

    Kind regards 

    Tony


    TKHussar

    • Marked as answer by TKHussar Wednesday, April 25, 2018 7:59 AM
    Wednesday, April 25, 2018 7:59 AM
  • Tony,

    Just for reference, this forum is not only for Project Server questions, it is for any questions about customizing and programming Microsoft Project, any version.

    John

    Wednesday, April 25, 2018 1:26 PM
  • Thanks John.

    TKHussar

    Wednesday, April 25, 2018 3:57 PM