Consulting

Results 1 to 3 of 3

Thread: Send email notifications code

  1. #1

    Send email notifications code

    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




  2. #2
    VBAX Regular arangogs's Avatar
    Joined
    Jun 2009
    Location
    Ayrshire, Scotland
    Posts
    18
    Location
    Hi ncuxonama ,

    The likely problem is with this line -

    For j = i + 1 To 9
    




    your array count is porbably\likely less than 9, therefore replace the 9 with ubound(arrEmails)

  3. #3
    Well what can i say? If there is a way I would buy you a beer. Everything works like a charm now. Thank you!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •