• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 3315
  • Last Modified:

Ms Project vba that creates filter for tasks that differ from baseline

I have the script below that was largely created by Rob Sampson (Thank you).

I need to add a variable that identifies tasks that have different start dates than the baseline.


Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub PrintFilteredResources()
    ' Macro PrintFilteredResources - loop on filters and then print
    ' $Id: PrintFilteredResources.txt,v 1.7 2000/08/23 23:24:10 phil Exp $
    ' Note: Ignores task dates that are 100% complete
    ' Todo: Handling multiple resource names better
    '       Select report from list instead of looping through them all
    On Error Resume Next                ' keep going on an error
    SelectBeginning                     ' restart from the beginning
    For Each Resource In ActiveProject.Resources
      If Resource.Work > 0 Then
        FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Resource Names", Test:="contains", Value:=Resource.Name, ShowInMenu:=False, ShowSummaryTasks:=True
        FilterApply Name:=Resource.Name ' apply the filter
        If (Err.Number) Then            ' saw an error applying filter
            MsgBox "ERROR: " & Err.Description
            Err.Clear                   ' clear out the error
            GoTo NextResource           ' jump to the next resource
        End If
        Start = 0                       ' reset start date
        Finish = 0                      ' reset finish date
        For Each Task In ActiveProject.Tasks
            If Not (Task Is Nothing) Then
                If (InStr(1, Task.ResourceNames, Resource.Name) And _
                    (Task.PercentComplete < 100)) Then
                    TryStart = Task.Start
                    TryFinish = Task.Finish
                    If (Start = 0) Then Start = TryStart    ' need a start date
                    If (Finish = 0) Then Finish = TryFinish ' need a finish date
                    ' see if we found an earlier start date / later finish date
                    If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart
                    If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish
                End If
            End If
        Next Task
        If (Start = 0) Then             ' no start date, nothing to see
            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
            GoTo NextResource           ' jump to the next resource
        End If
        Start = DateAdd("d", -3, Start)                     ' adjust a few days
        Finish = DateAdd("d", 3, Finish)                    ' adjust a few days
                 
            ' generate and save seperate .pdf files for each resource thanks to RobSampson
                strFullName = ActiveProject.FullName
                strBaseName = Mid(strFullName, InStrRev(strFullName, "\") + 1)
                strBaseName = Left(strBaseName, InStrRev(strBaseName, ".") - 1)
                Set objShell = CreateObject("WScript.Shell")
                strMyDocs = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal")
                If Right(strMyDocs, 1) <> "\" Then strMyDocs = strMyDocs & "\"
                strSource = strMyDocs & strBaseName & ".pdf"
                strTarget = "C:\MyDocs\" & strBaseName & "_" & Resource.Name & ".pdf"
                FilePrintSetup "Adobe PDF"
                FilePrint FromDate:=Start, ToDate:=Finish
                Sleep 3000
            ' this is where I would like to email the pdf to each resource
                FileCopy strSource, strTarget
                ' Email variables:
                strTo = Resource.EMailAddress
                strSubject = "Subject Here"
                strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

                If strTo <> "" Then
                    SendEmailWithOutlook strSubject, strTo, strBody, strTarget
                Else
                    MsgBox "Unknown email address for resource: " & Resource.Name
                End If

      End If
NextResource:
    Next Resource
    FilterApply Name:="All Tasks"       ' apply the filter
End Sub

Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)
    Const olMailItem = 0
    Const olFormatPlain = 1
    
    On Error Resume Next
    boolOutlookOpen = True
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
        objOutlook.Visible = True
        boolOutlookOpen = False
    End If
    Err.Clear
    Set objNameSpace = objOutlook.GetNamespace("mapi")
    Set objMailItem = objOutlook.CreateItem(olMailItem)
    With objMailItem
        .BodyFormat = olFormatPlain
        .To = strTo
        .Subject = strSubject
        .Body = strBody
        If strAttachment <> "" Then .Attachments.Add (strAttachment)
        .Send
        If Err.Number <> 0 Then MsgBox "Failed to send message. Error " & Err.Number & ": " & Err.Description
    End With
    If Err.Number = 0 Then
        objOutlook.sendandreceive False
    End If
    If Not boolOutlookOpen Then
        objOutlook.Quit
    End If
    Err.Clear
    On Error GoTo 0
End Sub

Open in new window

0
rjthomes
Asked:
rjthomes
  • 12
  • 8
1 Solution
 
RobSampsonCommented:
Hi,

What is the baseline date?  Where does that come from?

You already do some date testing with each Tasks Start date.....what other test to you need to perform?

Regards,

Rob.
0
 
rjthomesAuthor Commented:
Ok.

I have modified lines 13, 14 and 15.

The filter basically works.  I get the error below (image 40).

I think line 12       If Resource.Work > 0 Then

Using this line identifies any resource that performs work on the whole project.

I need it to identify resources in the filtered view (not the whole project) because there are some resources that have work > 0 but not necessarily in the tasks that have changed.

Any thoughts?

Chad


Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub PrintFilteredResourcesChanged()
    ' Macro PrintFilteredResources - loop on filters and then print
    ' $Id: PrintFilteredResources.txt,v 1.7 2000/08/23 23:24:10 phil Exp $
    ' Note: Ignores task dates that are 100% complete
    ' Todo: Handling multiple resource names better
    '       Select report from list instead of looping through them all
    On Error Resume Next                ' keep going on an error
    SelectBeginning                     ' restart from the beginning
    For Each Resource In ActiveProject.Resources
      If Resource.Work > 0 Then
        FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Baseline Start", Test:="does not equal", Value:="[Start]", ShowInMenu:=False, ShowSummaryTasks:=True
        FilterEdit Name:=Resource.Name, TaskFilter:=True, FieldName:="", NewFieldName:="Resource Names", Test:="contains", Value:=Resource.Name, Operation:="And", ShowSummaryTasks:=True
        FilterApply Name:=Resource.Name ' apply the filter
        If (Err.Number) Then            ' saw an error applying filter
            MsgBox "ERROR: " & Err.Description
            Err.Clear                   ' clear out the error
            GoTo NextResource           ' jump to the next resource
        End If
        Start = 0                       ' reset start date
        Finish = 0                      ' reset finish date
        For Each Task In ActiveProject.Tasks
            If Not (Task Is Nothing) Then
                If (InStr(1, Task.ResourceNames, Resource.Name) And _
                    (Task.PercentComplete < 100)) Then
                    TryStart = Task.Start
                    TryFinish = Task.Finish
                    If (Start = 0) Then Start = TryStart    ' need a start date
                    If (Finish = 0) Then Finish = TryFinish ' need a finish date
                    ' see if we found an earlier start date / later finish date
                    If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart
                    If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish
                End If
            End If
        Next Task
        If (Start = 0) Then             ' no start date, nothing to see
            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
            GoTo NextResource           ' jump to the next resource
        End If
        Start = DateAdd("d", -3, Start)                     ' adjust a few days
        Finish = DateAdd("d", 3, Finish)                    ' adjust a few days
                 
            ' generate and save seperate .pdf files for each resource thanks to RobSampson
                strFullName = ActiveProject.FullName
                strBaseName = Mid(strFullName, InStrRev(strFullName, "\") + 1)
                strBaseName = Left(strBaseName, InStrRev(strBaseName, ".") - 1)
                Set objShell = CreateObject("WScript.Shell")
                strMyDocs = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal")
                If Right(strMyDocs, 1) <> "\" Then strMyDocs = strMyDocs & "\"
                strSource = strMyDocs & strBaseName & ".pdf"
                strTarget = "C:\MyDocs\" & strBaseName & "_" & Resource.Name & ".pdf"
                FilePrintSetup "Adobe PDF"
                FilePrint FromDate:=Start, ToDate:=Finish
                Sleep 3000
            ' this is where I would like to email the pdf to each resource
                FileCopy strSource, strTarget
                ' Email variables:
                strTo = Resource.EMailAddress
                strSubject = "Subject Here"
                strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

                If strTo <> "" Then
                    SendEmailWithOutlook strSubject, strTo, strBody, strTarget
                Else
                    MsgBox "Unknown email address for resource: " & Resource.Name
                End If

      End If
NextResource:
    Next Resource
    FilterApply Name:="All Tasks"       ' apply the filter
End Sub

Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)
    Const olMailItem = 0
    Const olFormatPlain = 1
    
    On Error Resume Next
    boolOutlookOpen = True
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
        objOutlook.Visible = True
        boolOutlookOpen = False
    End If
    Err.Clear
    Set objNameSpace = objOutlook.GetNamespace("mapi")
    Set objMailItem = objOutlook.CreateItem(olMailItem)
    With objMailItem
        .BodyFormat = olFormatPlain
        .To = strTo
        .Subject = strSubject
        .Body = strBody
        If strAttachment <> "" Then .Attachments.Add (strAttachment)
        .Send
        If Err.Number <> 0 Then MsgBox "Failed to send message. Error " & Err.Number & ": " & Err.Description
    End With
    If Err.Number = 0 Then
        objOutlook.sendandreceive False
    End If
    If Not boolOutlookOpen Then
        objOutlook.Quit
    End If
    Err.Clear
    On Error GoTo 0
End Sub

Open in new window

Untitled-40.jpg
0
 
rjthomesAuthor Commented:
Rob,

It seems reasonable that

If (Start = 0) Then             ' no start date, nothing to see
            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
            GoTo NextResource           ' jump to the next resource
        End If

would identify the absence of work and send it to the next resource.

Chad
0
Never miss a deadline with monday.com

The revolutionary project management tool is here!   Plan visually with a single glance and make sure your projects get done.

 
RobSampsonCommented:
Wouldn't your filter on line 13 just get overwritten by the filter on line 14?  Or does that add extra criteria to it?  Did you get these lines from a recorded macro?

If you need to query both filters separately, we might need to add a loop to go through both filters after applying them...

Rob.
0
 
RobSampsonCommented:
>> would identify the absence of work and send it to the next resource

Yes, I would have thought so....does it not?
0
 
rjthomesAuthor Commented:
Rob,

I would have thought that except for the' Operation:="And"'
in line 14.

Not sure.  It seems to work until it runs into a resource that has work >0 on the project but none of it occurs in the filter.

Take a look at the screen where you set up such a filter and look at the resulting macro when I record doing it.

Chad
Sub Macro4()
' Macro Macro4
' Macro Recorded Wed 9/1/10 by Chad.
    FilterEdit Name:="Filter 5", TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Baseline Start", Test:="does not equal", Value:="[Start]", ShowInMenu:=False, ShowSummaryTasks:=True
    FilterEdit Name:="Filter 5", TaskFilter:=True, FieldName:="", NewFieldName:="Resource Names", Test:="contains", Value:="", Operation:="And", ShowSummaryTasks:=True
End Sub

Open in new window

Untitled-60.jpg
0
 
rjthomesAuthor Commented:
Rob,

I also noticed that line 13 has

OverwriteExisting:=True

but line 14 does not.

Chad
0
 
RobSampsonCommented:
OK, so, you are correct in saying that this line:
If Resource.Work > 0 Then

identifies any resource that performs work on the whole project, because this occurs before applying the filter.

What happens if you just move that line to above this line
        Start = 0                       ' reset start date

What that will hopefully do is apply the filter and *then* check the resource work....

Rob.

0
 
rjthomesAuthor Commented:
Rob,

I actually tested a couple of spots in the code (they all acted the same).

It freezes up.  I actually have to kill the program.

Is the loop not complete?

Chad
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub PrintFilteredResourcesChanged()
    ' Macro PrintFilteredResources - loop on filters and then print
    ' $Id: PrintFilteredResources.txt,v 1.7 2000/08/23 23:24:10 phil Exp $
    ' Note: Ignores task dates that are 100% complete
    ' Todo: Handling multiple resource names better
    '       Select report from list instead of looping through them all
    On Error Resume Next                ' keep going on an error
    SelectBeginning                     ' restart from the beginning
    For Each Resource In ActiveProject.Resources
      'If Resource.Work > 0 Then
        FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Baseline Start", Test:="does not equal", Value:="[Start]", ShowInMenu:=False, ShowSummaryTasks:=True
        FilterEdit Name:=Resource.Name, TaskFilter:=True, FieldName:="", NewFieldName:="Resource Names", Test:="contains", Value:=Resource.Name, Operation:="And", ShowSummaryTasks:=True
        FilterApply Name:=Resource.Name ' apply the filter
        If (Err.Number) Then            ' saw an error applying filter
            MsgBox "ERROR: " & Err.Description
            Err.Clear                   ' clear out the error
            GoTo NextResource           ' jump to the next resource
        End If
        
       If Resource.Work > 0 Then
        Start = 0                       ' reset start date
        Finish = 0                      ' reset finish date
        For Each Task In ActiveProject.Tasks
            If Not (Task Is Nothing) Then
                If (InStr(1, Task.ResourceNames, Resource.Name) And _
                    (Task.PercentComplete < 100)) Then
                    TryStart = Task.Start
                    TryFinish = Task.Finish
                    If (Start = 0) Then Start = TryStart    ' need a start date
                    If (Finish = 0) Then Finish = TryFinish ' need a finish date
                    ' see if we found an earlier start date / later finish date
                    If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart
                    If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish
                End If
            End If
        Next Task
        
 
        If (Start = 0) Then             ' no start date, nothing to see
            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
            GoTo NextResource           ' jump to the next resource
        End If
      
        Start = DateAdd("d", -3, Start)                     ' adjust a few days
        Finish = DateAdd("d", 3, Finish)                    ' adjust a few days
                 
            ' generate and save seperate .pdf files for each resource thanks to RobSampson
                strFullName = ActiveProject.FullName
                strBaseName = Mid(strFullName, InStrRev(strFullName, "\") + 1)
                strBaseName = Left(strBaseName, InStrRev(strBaseName, ".") - 1)
                Set objShell = CreateObject("WScript.Shell")
                strMyDocs = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal")
                If Right(strMyDocs, 1) <> "\" Then strMyDocs = strMyDocs & "\"
                strSource = strMyDocs & strBaseName & ".pdf"
                strTarget = "C:\MyDocs\" & strBaseName & "_" & Resource.Name & ".pdf"
                FilePrintSetup "Adobe PDF"
                FilePrint FromDate:=Start, ToDate:=Finish
                Sleep 3000
            ' this is where I would like to email the pdf to each resource
                FileCopy strSource, strTarget
                ' Email variables:
                strTo = Resource.EMailAddress
                strSubject = "Subject Here"
                strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

                If strTo <> "" Then
                    SendEmailWithOutlook strSubject, strTo, strBody, strTarget
                Else
                    MsgBox "Unknown email address for resource: " & Resource.Name
                End If

      End If
NextResource:
    Next Resource
    FilterApply Name:="All Tasks"       ' apply the filter
End Sub

Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)
    Const olMailItem = 0
    Const olFormatPlain = 1
    
    On Error Resume Next
    boolOutlookOpen = True
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
        objOutlook.Visible = True
        boolOutlookOpen = False
    End If
    Err.Clear
    Set objNameSpace = objOutlook.GetNamespace("mapi")
    Set objMailItem = objOutlook.CreateItem(olMailItem)
    With objMailItem
        .BodyFormat = olFormatPlain
        .To = strTo
        .Subject = strSubject
        .Body = strBody
        If strAttachment <> "" Then .Attachments.Add (strAttachment)
        .Send
        If Err.Number <> 0 Then MsgBox "Failed to send message. Error " & Err.Number & ": " & Err.Description
    End With
    If Err.Number = 0 Then
        objOutlook.sendandreceive False
    End If
    If Not boolOutlookOpen Then
        objOutlook.Quit
    End If
    Err.Clear
    On Error GoTo 0
End Sub

Open in new window

0
 
rjthomesAuthor Commented:
Rob,

I think

        If (Start = 0) Then             ' no start date, nothing to see
            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
            GoTo NextResource           ' jump to the next resource
        End If

still looks at the whole project.  Not the filtered portion.

You probably new that.

Chad
0
 
RobSampsonCommented:
Bugger....OK, so how about we go back to what it was before, by checking the overall work, and then, hopefully the next
If Resource.Work > 0 Then

will check based on the filtered data.

However, looking again at this line:
                        For Each Task In ActiveProject.Tasks

that is probably what is checking all tasks, not just the filtered tasks.....what if you change that to
                        For Each Task In ActiveSelection.Tasks

Regards,

Rob.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub PrintFilteredResourcesChanged()
	' Macro PrintFilteredResources - loop on filters and then print
	' $Id: PrintFilteredResources.txt,v 1.7 2000/08/23 23:24:10 phil Exp $
	' Note: Ignores task dates that are 100% complete
	' Todo: Handling multiple resource names better
	'       Select report from list instead of looping through them all
	On Error Resume Next                ' keep going on an error
	SelectBeginning                     ' restart from the beginning
	For Each Resource In ActiveProject.Resources
		If Resource.Work > 0 Then
			FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Baseline Start", Test:="does not equal", Value:="[Start]", ShowInMenu:=False, ShowSummaryTasks:=True
			FilterEdit Name:=Resource.Name, TaskFilter:=True, FieldName:="", NewFieldName:="Resource Names", Test:="contains", Value:=Resource.Name, Operation:="And", ShowSummaryTasks:=True
			FilterApply Name:=Resource.Name ' apply the filter
			If (Err.Number) Then            ' saw an error applying filter
				MsgBox "ERROR: " & Err.Description
				Err.Clear                   ' clear out the error
				GoTo NextResource           ' jump to the next resource
			End If

			If Resource.Work > 0 Then
				Start = 0                       ' reset start date
				Finish = 0                      ' reset finish date
				For Each Task In ActiveProject.Tasks
					If Not (Task Is Nothing) Then
						If (InStr(1, Task.ResourceNames, Resource.Name) And (Task.PercentComplete < 100)) Then
							TryStart = Task.Start
							TryFinish = Task.Finish
							If (Start = 0) Then Start = TryStart    ' need a start date
							If (Finish = 0) Then Finish = TryFinish ' need a finish date
							' see if we found an earlier start date / later finish date
							If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart
							If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish
						End If
					End If
				Next Task

				If (Start = 0) Then             ' no start date, nothing to see
					'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
					GoTo NextResource           ' jump to the next resource
				End If
      
				Start = DateAdd("d", -3, Start)                     ' adjust a few days
				Finish = DateAdd("d", 3, Finish)                    ' adjust a few days
				
				' generate and save seperate .pdf files for each resource thanks to RobSampson
				strFullName = ActiveProject.FullName
				strBaseName = Mid(strFullName, InStrRev(strFullName, "\") + 1)
				strBaseName = Left(strBaseName, InStrRev(strBaseName, ".") - 1)
				Set objShell = CreateObject("WScript.Shell")
				strMyDocs = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal")
				If Right(strMyDocs, 1) <> "\" Then strMyDocs = strMyDocs & "\"
				strSource = strMyDocs & strBaseName & ".pdf"
				strTarget = "C:\MyDocs\" & strBaseName & "_" & Resource.Name & ".pdf"
				FilePrintSetup "Adobe PDF"
				FilePrint FromDate:=Start, ToDate:=Finish
				Sleep 3000
				' this is where I would like to email the pdf to each resource
				FileCopy strSource, strTarget
				' Email variables:
				strTo = Resource.EMailAddress
				strSubject = "Subject Here"
				strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

				If strTo <> "" Then
					SendEmailWithOutlook strSubject, strTo, strBody, strTarget
				Else
					MsgBox "Unknown email address for resource: " & Resource.Name
				End If
			End If
		End If
NextResource:
    Next Resource
    FilterApply Name:="All Tasks"       ' apply the filter
End Sub

Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)
    Const olMailItem = 0
    Const olFormatPlain = 1
    
    On Error Resume Next
    boolOutlookOpen = True
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
        objOutlook.Visible = True
        boolOutlookOpen = False
    End If
    Err.Clear
    Set objNameSpace = objOutlook.GetNamespace("mapi")
    Set objMailItem = objOutlook.CreateItem(olMailItem)
    With objMailItem
        .BodyFormat = olFormatPlain
        .To = strTo
        .Subject = strSubject
        .Body = strBody
        If strAttachment <> "" Then .Attachments.Add (strAttachment)
        .Send
        If Err.Number <> 0 Then MsgBox "Failed to send message. Error " & Err.Number & ": " & Err.Description
    End With
    If Err.Number = 0 Then
        objOutlook.sendandreceive False
    End If
    If Not boolOutlookOpen Then
        objOutlook.Quit
    End If
    Err.Clear
    On Error GoTo 0
End Sub

Open in new window

0
 
rjthomesAuthor Commented:
Rob,

The above code generated the same set of problems.

When I substituted

For Each Task In ActiveSelection.Tasks

I got the error below although I think you are on the right track with it.

Chad
Untitled-70.jpg
0
 
RobSampsonCommented:
OK, with some guidance from here:
http://zo-d.com/blog/archives/programming/working-with-the-tasks-collection.html

how about above this line:

For Each Task In ActiveSelection.Tasks

add this

SelectAll

Sorry for my stabs in the dark.......Project isn't one of my strong points....

Rob.
0
 
rjthomesAuthor Commented:
Rob,

I hope you understand how much I appreciate your 'stabs in the dark'.

That creates the same error (with the exception that I can see it selecting all).

That is an interesting website.  We are already using some of it.

I think this is possibly where we need to query 'task nothing"  as that page suggested.

        If (Start = 0) Then             ' no start date, nothing to see
            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
            GoTo NextResource           ' jump to the next resource
        End If

"This approach works until you hit a blank line in the project. In the case of the blank line the task is what Project refers to as "Nothing". You can do nothing with Nothing, so setting the Text5 value for Nothing will give you an error. Luckily you can check to see if a task is Nothing and therefore skip doing anything that would cause an error and stop your code. To do this we add a simple If statement:

For Each t in ts
If not t is Nothing then
t.Text5 = "Foo"
End If
Next t
"

The error occurs when it tries to print nothing.

This code is just before the print section.

Chad
I am sure I am off course, just trying to make decent suggestions.

Chad
0
 
rjthomesAuthor Commented:
Rob,

Something like this.

        If (Start = 0) And (Task Is Nothing) Then            ' no start date, nothing to see
            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
            GoTo NextResource           ' jump to the next resource
        End If

Not sure if the 'And (Task Is Nothing)' is correct but these are my thoughts.

Chad
0
 
RobSampsonCommented:
That *should* work.....give it a shot.....another thing....can you comment out the
On Error Resume Next

so we can pinpoint where it's causing an error, and work on that part....

Rob.
0
 
rjthomesAuthor Commented:
Rob.

I tried my earlier suggestion and it failed.

However.  I read that web page about 30 times until I sort of got it.

This code works.  I need to do some testing and will let you know.

        SelectAll
        If (ActiveSelection.Tasks Is Nothing) Then
            GoTo NextResource
        End If
           

Take a look and let me know what you think.

Chad
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub PrintFilteredResourcesChanged()
    ' Macro PrintFilteredResources - loop on filters and then print
    ' $Id: PrintFilteredResources.txt,v 1.7 2000/08/23 23:24:10 phil Exp $
    ' Note: Ignores task dates that are 100% complete
    ' Todo: Handling multiple resource names better
    '       Select report from list instead of looping through them all
    On Error Resume Next                ' keep going on an error
    SelectBeginning                     ' restart from the beginning
    For Each Resource In ActiveProject.Resources
      If Resource.Work > 0 Then
        FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Baseline Start", Test:="does not equal", Value:="[Start]", ShowInMenu:=False, ShowSummaryTasks:=True
        FilterEdit Name:=Resource.Name, TaskFilter:=True, FieldName:="", NewFieldName:="Resource Names", Test:="contains", Value:=Resource.Name, Operation:="And", ShowSummaryTasks:=True
        FilterApply Name:=Resource.Name ' apply the filter
        If (Err.Number) Then            ' saw an error applying filter
            MsgBox "ERROR: " & Err.Description
            Err.Clear                   ' clear out the error
            GoTo NextResource           ' jump to the next resource
        End If
        
        Start = 0                       ' reset start date
        Finish = 0                      ' reset finish date
        
        
        For Each Task In ActiveProject.Tasks
            If Not (Task Is Nothing) Then
                If (InStr(1, Task.ResourceNames, Resource.Name) And _
                    (Task.PercentComplete < 100)) Then
                    TryStart = Task.Start
                    TryFinish = Task.Finish
                    If (Start = 0) Then Start = TryStart    ' need a start date
                    If (Finish = 0) Then Finish = TryFinish ' need a finish date
                    ' see if we found an earlier start date / later finish date
                    If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart
                    If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish
                End If
            End If
        Next Task
        
 
 
        SelectAll
        If (ActiveSelection.Tasks Is Nothing) Then
            GoTo NextResource
        End If
            
            
        If (Start = 0) Then           ' no start date, nothing to see
            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
            GoTo NextResource           ' jump to the next resource
        End If
      
      
      
        Start = DateAdd("d", -3, Start)                     ' adjust a few days
        Finish = DateAdd("d", 3, Finish)                    ' adjust a few days
                 
            ' generate and save seperate .pdf files for each resource thanks to RobSampson
                strFullName = ActiveProject.FullName
                strBaseName = Mid(strFullName, InStrRev(strFullName, "\") + 1)
                strBaseName = Left(strBaseName, InStrRev(strBaseName, ".") - 1)
                Set objShell = CreateObject("WScript.Shell")
                strMyDocs = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal")
                If Right(strMyDocs, 1) <> "\" Then strMyDocs = strMyDocs & "\"
                strSource = strMyDocs & strBaseName & ".pdf"
                strTarget = "C:\MyDocs\" & strBaseName & "_" & Resource.Name & ".pdf"
                FilePrintSetup "Adobe PDF"
                FilePrint FromDate:=Start, ToDate:=Finish
                Sleep 3000
            ' this is where I would like to email the pdf to each resource
                FileCopy strSource, strTarget
                ' Email variables:
                strTo = Resource.EMailAddress
                strSubject = "Subject Here"
                strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

                If strTo <> "" Then
                    SendEmailWithOutlook strSubject, strTo, strBody, strTarget
                Else
                    MsgBox "Unknown email address for resource: " & Resource.Name
                End If

      End If
NextResource:
    Next Resource
    FilterApply Name:="All Tasks"       ' apply the filter
End Sub

Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)
    Const olMailItem = 0
    Const olFormatPlain = 1
    
    On Error Resume Next
    boolOutlookOpen = True
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
        objOutlook.Visible = True
        boolOutlookOpen = False
    End If
    Err.Clear
    Set objNameSpace = objOutlook.GetNamespace("mapi")
    Set objMailItem = objOutlook.CreateItem(olMailItem)
    With objMailItem
        .BodyFormat = olFormatPlain
        .To = strTo
        .Subject = strSubject
        .Body = strBody
        If strAttachment <> "" Then .Attachments.Add (strAttachment)
        .Send
        If Err.Number <> 0 Then MsgBox "Failed to send message. Error " & Err.Number & ": " & Err.Description
    End With
    If Err.Number = 0 Then
        objOutlook.sendandreceive False
    End If
    If Not boolOutlookOpen Then
        objOutlook.Quit
    End If
    Err.Clear
    On Error GoTo 0
End Sub

Open in new window

0
 
RobSampsonCommented:
Hmmm, that's seems a bit odd....as far as I can tell, you would still be going through the ActiveProject.Tasks, and not the filtered task set, but I could be wrong....

If you needed to test, you could add
MsgBox "Checking task: " & Task.Name

after this line:
                        If Not (Task Is Nothing) Then

and you will see the name of each task it goes through at that point....

Actually....perhaps that's what the For error was about!  The fact that ActiveSelection.Tasks might be Nothing, which we didn't check for before the For Each Task In ActiveSelection.Tasks line.....if you testing doesn't produce the results you need, try this.

Regards,

Rob.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub PrintFilteredResourcesChanged()
	' Macro PrintFilteredResources - loop on filters and then print
	' $Id: PrintFilteredResources.txt,v 1.7 2000/08/23 23:24:10 phil Exp $
	' Note: Ignores task dates that are 100% complete
	' Todo: Handling multiple resource names better
	'       Select report from list instead of looping through them all
	On Error Resume Next                ' keep going on an error
	SelectBeginning                     ' restart from the beginning
	For Each Resource In ActiveProject.Resources
		If Resource.Work > 0 Then
			FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Baseline Start", Test:="does not equal", Value:="[Start]", ShowInMenu:=False, ShowSummaryTasks:=True
			FilterEdit Name:=Resource.Name, TaskFilter:=True, FieldName:="", NewFieldName:="Resource Names", Test:="contains", Value:=Resource.Name, Operation:="And", ShowSummaryTasks:=True
			FilterApply Name:=Resource.Name ' apply the filter
			If (Err.Number) Then            ' saw an error applying filter
				MsgBox "ERROR: " & Err.Description
				Err.Clear                   ' clear out the error
				GoTo NextResource           ' jump to the next resource
			End If
        
			Start = 0                       ' reset start Date
			Finish = 0                      ' reset finish date
        
			SelectAll
			If ActiveSelection.Tasks Is Nothing Then GoTo NextResource
			For Each Task In ActiveSelection.Tasks
				If Not (Task Is Nothing) Then
					If (InStr(1, Task.ResourceNames, Resource.Name) And (Task.PercentComplete < 100)) Then
						TryStart = Task.Start
						TryFinish = Task.Finish
						If (Start = 0) Then Start = TryStart    ' need a start date
						If (Finish = 0) Then Finish = TryFinish ' need a finish date
						' see if we found an earlier start date / later finish date
						If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart
						If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish
					End If
				End If
			Next Task
            
			If (Start = 0) Then           ' no start date, nothing to see
				'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
				GoTo NextResource           ' jump to the next resource
			End If

			Start = DateAdd("d", -3, Start)                     ' adjust a few days
			Finish = DateAdd("d", 3, Finish)                    ' adjust a few days

			' generate and save seperate .pdf files for each resource thanks to RobSampson
			strFullName = ActiveProject.FullName
			strBaseName = Mid(strFullName, InStrRev(strFullName, "\") + 1)
			strBaseName = Left(strBaseName, InStrRev(strBaseName, ".") - 1)
			Set objShell = CreateObject("WScript.Shell")
			strMyDocs = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal")
			If Right(strMyDocs, 1) <> "\" Then strMyDocs = strMyDocs & "\"
			strSource = strMyDocs & strBaseName & ".pdf"
			strTarget = "C:\MyDocs\" & strBaseName & "_" & Resource.Name & ".pdf"
			FilePrintSetup "Adobe PDF"
			FilePrint FromDate:=Start, ToDate:=Finish
			Sleep 3000
			' this is where I would like to email the pdf to each resource
			FileCopy strSource, strTarget
			' Email variables:
			strTo = Resource.EMailAddress
			strSubject = "Subject Here"
			strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

			If strTo <> "" Then
				SendEmailWithOutlook strSubject, strTo, strBody, strTarget
			Else
				MsgBox "Unknown email address for resource: " & Resource.Name
			End If

		End If
NextResource:
    Next Resource
    FilterApply Name:="All Tasks"       ' apply the filter
End Sub

Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)
    Const olMailItem = 0
    Const olFormatPlain = 1
    
    On Error Resume Next
    boolOutlookOpen = True
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
        objOutlook.Visible = True
        boolOutlookOpen = False
    End If
    Err.Clear
    Set objNameSpace = objOutlook.GetNamespace("mapi")
    Set objMailItem = objOutlook.CreateItem(olMailItem)
    With objMailItem
        .BodyFormat = olFormatPlain
        .To = strTo
        .Subject = strSubject
        .Body = strBody
        If strAttachment <> "" Then .Attachments.Add (strAttachment)
        .Send
        If Err.Number <> 0 Then MsgBox "Failed to send message. Error " & Err.Number & ": " & Err.Description
    End With
    If Err.Number = 0 Then
        objOutlook.sendandreceive False
    End If
    If Not boolOutlookOpen Then
        objOutlook.Quit
    End If
    Err.Clear
    On Error GoTo 0
End Sub

Open in new window

0
 
rjthomesAuthor Commented:
Rob,

Ok...  It looks like it works but I had to make a few changes (that website you found was pretty helpful, it gave me some ideas)

No errors and seemed to print everything correct.

I tried to work with what you gave me above but this is what worked.

        SelectAll
        If (ActiveSelection = 0) Then
            GoTo NextResource
        End If
        For Each Task In ActiveSelection.Tasks
            'MsgBox "Checking task: " & Task.Name
             If Not (Task Is Nothing) Then
                 If (InStr(1, Task.ResourceNames, Resource.Name) And _
                    (Task.PercentComplete < 100)) Then
                    TryStart = Task.Start
                    TryFinish = Task.Finish
                    If (Start = 0) Then Start = TryStart    ' need a start date
                    If (Finish = 0) Then Finish = TryFinish ' need a finish date
                    ' see if we found an earlier start date / later finish date
                    If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart
                    If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish
                End If
            End If
        Next Task


I did raise the sleep to 10000.  Sometimes if the computer is busy that old error would come up.

The code below is the final product.

Anyway.  Thank you again and again!!!!

I have more things for this macro.  Hopefully I can get your interest.  I will put a link in my next comment.

Chad
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub PrintFilteredResourcesChanged()
    ' Macro PrintFilteredResources - loop on filters and then print
    ' $Id: PrintFilteredResources.txt,v 1.7 2000/08/23 23:24:10 phil Exp $
    ' Note: Ignores task dates that are 100% complete
    ' Todo: Handling multiple resource names better
    '       Select report from list instead of looping through them all
    On Error Resume Next                ' keep going on an error
    SelectBeginning                     ' restart from the beginning
    For Each Resource In ActiveProject.Resources
      If Resource.Work > 0 Then
        FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Baseline Start", Test:="does not equal", Value:="[Start]", ShowInMenu:=False, ShowSummaryTasks:=True
        FilterEdit Name:=Resource.Name, TaskFilter:=True, FieldName:="", NewFieldName:="Resource Names", Test:="contains", Value:=Resource.Name, Operation:="And", ShowSummaryTasks:=True
        FilterApply Name:=Resource.Name ' apply the filter
        If (Err.Number) Then            ' saw an error applying filter
            MsgBox "ERROR: " & Err.Description
            Err.Clear                   ' clear out the error
            GoTo NextResource           ' jump to the next resource
        End If
        Start = 0                       ' reset start date
        Finish = 0                      ' reset finish date
        SelectAll
        If (ActiveSelection = 0) Then
            GoTo NextResource
        End If
        For Each Task In ActiveSelection.Tasks
            'MsgBox "Checking task: " & Task.Name
             If Not (Task Is Nothing) Then
                 If (InStr(1, Task.ResourceNames, Resource.Name) And _
                    (Task.PercentComplete < 100)) Then
                    TryStart = Task.Start
                    TryFinish = Task.Finish
                    If (Start = 0) Then Start = TryStart    ' need a start date
                    If (Finish = 0) Then Finish = TryFinish ' need a finish date
                    ' see if we found an earlier start date / later finish date
                    If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart
                    If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish
                End If
            End If
        Next Task
        If (Start = 0) Then           ' no start date, nothing to see
            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name
            GoTo NextResource           ' jump to the next resource
        End If
        Start = DateAdd("d", -3, Start)                     ' adjust a few days
        Finish = DateAdd("d", 3, Finish)                    ' adjust a few days
                 
            ' generate and save seperate .pdf files for each resource thanks to RobSampson
                strFullName = ActiveProject.FullName
                strBaseName = Mid(strFullName, InStrRev(strFullName, "\") + 1)
                strBaseName = Left(strBaseName, InStrRev(strBaseName, ".") - 1)
                Set objShell = CreateObject("WScript.Shell")
                strMyDocs = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal")
                If Right(strMyDocs, 1) <> "\" Then strMyDocs = strMyDocs & "\"
                strSource = strMyDocs & strBaseName & ".pdf"
                strTarget = "C:\MyDocs\" & strBaseName & "_" & Resource.Name & ".pdf"
                FilePrintSetup "Adobe PDF"
                FilePrint FromDate:=Start, ToDate:=Finish
                Sleep 10000
                FileCopy strSource, strTarget
                ' Email variables:
                strTo = Resource.EMailAddress
                strSubject = "Subject Here"
                strBody = "Please find attached a copy of your resource schedule:" & vbCrLf
                If strTo <> "" Then
                    SendEmailWithOutlook strSubject, strTo, strBody, strTarget
                Else
                    MsgBox "Unknown email address for resource: " & Resource.Name
                End If
      End If
NextResource:
    Next Resource
    FilterApply Name:="All Tasks"       ' apply the filter
End Sub

Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)
    Const olMailItem = 0
    Const olFormatPlain = 1
    On Error Resume Next
    boolOutlookOpen = True
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
        objOutlook.Visible = True
        boolOutlookOpen = False
    End If
    Err.Clear
    Set objNameSpace = objOutlook.GetNamespace("mapi")
    Set objMailItem = objOutlook.CreateItem(olMailItem)
    With objMailItem
        .BodyFormat = olFormatPlain
        .To = strTo
        .Subject = strSubject
        .Body = strBody
        If strAttachment <> "" Then .Attachments.Add (strAttachment)
        .Send
        If Err.Number <> 0 Then MsgBox "Failed to send message. Error " & Err.Number & ": " & Err.Description
    End With
    If Err.Number = 0 Then
        objOutlook.sendandreceive False
    End If
    If Not boolOutlookOpen Then
        objOutlook.Quit
    End If
    Err.Clear
    On Error GoTo 0
End Sub

Open in new window

0
 
rjthomesAuthor Commented:
0

Featured Post

The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

  • 12
  • 8
Tackle projects and never again get stuck behind a technical roadblock.
Join Now