Predecessor dependency in MS Project 2007 Emailing Macro

[dmpyne]

I have put together a macro in MS Project 2007 that sends resources an email with an Excel file attached that lists all of their tasks that are due according to the status date.

However I would like to only include tasks in each email whose predecessor tasks are complete.

This is probably just a few lines of an IF-THEN statement that needs to be added somewhere in my macro.

Below is my macro, please let me know what I need to add.

' Emailing Daily Status out to addresses

Public Sub Email_Task_Report()

Dim sEmailMessage As String
Dim sfilename As String
Dim sResourceGroup As String
Dim sEmails As String
Dim oResource As Resource
Dim oAssignment As Assignment
Dim oTask As Task
Dim dTodayDate As Date
dTodayDate = Now()
Dim dFriday As Date
dFriday = Now + (7 - Weekday(Now)) 'actually returns Sat
Dim oTaskFound As Boolean

Set proProj = ActiveProject
On Error Resume Next

ResourcePromptLine:
sResourceGroup = InputBox("Enter Resource Group", "Resource Group", "")

If Len(sResourceGroup) = 0 Then
spromptanswer = MsgBox("Please Enter a resource group", vbOKCancel)
If spromptanswer = vbOK Then
GoTo ResourcePromptLine
Else
Exit Sub
End If
End If


sEmails = MsgBox("Do you want to send emails?", vbYesNo)
If sEmails = "6" Then

frmGetMessage.Show
sEmailMessage = frmGetMessage.txtMessage.Text

End If


''''''
If oExcelApplication Is Nothing Then
Set oExcelApplication = CreateObject("Excel.Application") 'Start new instance
If oExcelApplication Is Nothing Then
MsgBox "Can't Find Excel, please try again.", vbCritical
End 'Stop, can't proceed without Excel
End If
oExcelApplication.Visible = True
Else
Set oexcelrange = Nothing
Set oExcelApplication = Nothing
Set oExcelWorkbook = Nothing
Set oExcelApplication = CreateObject("Excel.Application") ' Start New Instance
If oExcelApplication Is Nothing Then
MsgBox "Can't Find Excel, please try again.", vbCritical
End 'Stop, can't proceed without Excel
End If
oExcelApplication.Visible = True
End If
''''''


Application.ActivateMicrosoftApp pjMicrosoftExcel

'Create new Excel file. Add worksheets and name all of them (10)
On Error Resume Next

For Each oResource In ActiveProject.Resources

If Not (oResource Is Nothing) Then
If oResource.Group = sResourceGroup Then
Set oExcelWorkbook = oExcelApplication.Workbooks.Add
oExcelApplication.Calculation = gCnxlCalculationManual ' Set Manual Calculation

With oExcelWorkbook
.Worksheets(1).Name = "Task Report"
.Worksheets(1).Activate
Set oexcelrange = .Worksheets(1).Range("A1")

With oexcelrange
.Range("A1").ColumnWidth = 20
.Range("B1").ColumnWidth = 18
.Range("C1").ColumnWidth = 55
.Range("D:E").ColumnWidth = 20
.Range("F:G").ColumnWidth = 14
.Range("H:H").ColumnWidth = 30
.Range("B7:B50").EntireColumn.NumberFormat = "0%"
.Range("E1").EntireColumn.NumberFormat = "#,##0"
.Range("F1").EntireColumn.NumberFormat = "MM/DD/YYYY"
.Range("G1").EntireColumn.NumberFormat = "MM/DD/YYYY"
With .Range("A6:H6").Interior
.ColorIndex = 35
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With .Range("A7:B50").Interior
.ColorIndex = 48
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With .Range("F7:G50").Interior
.ColorIndex = 48
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End With ' oExcelRange

'Worksheet headings and other details formatting
oexcelrange.Range("A1").Formula = "Daily Status Report"
oexcelrange.Range("A2").Formula = "Current Date"
oexcelrange.Range("B2").Formula = Now()
oexcelrange.Range("A3").Formula = "Resource"
oexcelrange.Range("B3").Formula = oResource.Name

With oexcelrange.Range("A1:A3")
.Font.Bold = True
.Font.Size = 12
End With

Set oexcelrange = oexcelrange.Range("A6")
End With

'Gathering information for each task below
'Add headers for base measures of task, date and hours worked.Format the column headings
oexcelrange.Range("A1:H1") = Array("Unique ID", _
"% Complete", _
"Task Name/Description", _
"Team Owner", _
"Remaining Work (hrs)", _
"Baseline Start", _
"Baseline Finish", _
"Notes")
Set oexcelrange = oexcelrange.Offset(1, 0)


oTaskFound = False

'Add headers for base measures of task, date and hours worked.Format the column headings


''''''''''''''I believe the following statement is where this new predecessor condition needs to be added.''''''''''



For Each oAssignment In oResource.Assignments
If oAssignment.RemainingWork > 0 And oAssignment.Start <= dTodayDate Then
oexcelrange.Range("A1:H1") = Array(oAssignment.TaskUniqueID, _
(oAssignment.PercentWorkComplete / 100), _
oAssignment.TaskName, _
ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqu eID).Text1, _
(oAssignment.RemainingWork / 60), _
ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqu eID).BaselineStart, _
ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqu eID).BaselineFinish, _
ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqu eID).Notes)
Set oexcelrange = oexcelrange.Offset(1, 0)
oTaskFound = True
End If
Next oAssignment


'''''''Make sure you add/have a temp folder on your hard drive or else it wont save''''''''''''
Application.ScreenUpdating = True
sfiletitle = oResource.Name & "_" & format(Date, "mmm_dd_yyyy") & ".xls"
sfilename = "C:\temp\" & sfiletitle
ActiveWorkbook.SaveAs FileName:=sfilename
ActiveWorkbook.Close


' Emailing Outlook 2010
If sEmails = "6" And oTaskFound = True Then

Dim OutApp As Object
Dim OutMail As Object
Dim SenderEmailAddress As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.SentOnBehalfOfName = "(e-mail address removed)"
.To = oResource.EMailAddress
'.CC = "(e-mail address removed)" & ";" & "(e-mail address removed)"
.BCC = ""
.Subject = "Daily Cutover Tasks;" & " " & format(Date, "mmm dd, yyyy")
.Body = "Attached are your cutover tasks for today" & " " & format(Date, "mmm dd, yyyy")
.Attachments.Add ("C:\temp\" & sfiletitle)
.Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

End If
'''End Emailing


End If

Else
Exit For

End If

Next oResource

Call MsgBox("Compiled and Emailed Tasks")


End Sub

 

[[email protected]]

It may help you out

Sub ReadyToStart()

'This macro will filter to show only tasks that have
'all of their predecessors are 100% complete
'and which are not already marked complete themselves

Dim t, pt, ct, wp As Task
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then

If t.PercentComplete = 100 Then
t.Text30 = "Completed"
Else
t.Text30 = "Yes"
End If

For Each pt In t.PredecessorTasks
If pt.PercentComplete < 100 Then
t.Text30 = "No"
If t.Text30 = "No" Then Exit For
Else
If t.PercentComplete = 100 Then
t.Text30 = "Completed"
Else
t.Text30 = "Yes"
End If
End If
Next pt

End If
Next t
End Sub


I am looking for a macro to send emails to the task owner telling then they are ready to star based on the flag (Text30) and the restrition "As soon as possible".
Do you have any idea how to do that?
Thank you