Solved

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

Posted on 2010-09-01
20
2,919 Views
Last Modified: 2013-11-15
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
Comment
Question by:rjthomes
  • 12
  • 8
20 Comments
 
LVL 65

Expert Comment

by:RobSampson
ID: 33583468
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
 

Author Comment

by:rjthomes
ID: 33583477
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
 

Author Comment

by:rjthomes
ID: 33583503
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
 
LVL 65

Expert Comment

by:RobSampson
ID: 33583506
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
 
LVL 65

Expert Comment

by:RobSampson
ID: 33583513
>> would identify the absence of work and send it to the next resource

Yes, I would have thought so....does it not?
0
 

Author Comment

by:rjthomes
ID: 33583539
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
 

Author Comment

by:rjthomes
ID: 33583552
Rob,

I also noticed that line 13 has

OverwriteExisting:=True

but line 14 does not.

Chad
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 33592372
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
 

Author Comment

by:rjthomes
ID: 33592670
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
 

Author Comment

by:rjthomes
ID: 33592928
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
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
LVL 65

Expert Comment

by:RobSampson
ID: 33592968
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
 

Author Comment

by:rjthomes
ID: 33593213
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
 
LVL 65

Expert Comment

by:RobSampson
ID: 33593250
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
 

Author Comment

by:rjthomes
ID: 33593284
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
 

Author Comment

by:rjthomes
ID: 33593291
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
 
LVL 65

Expert Comment

by:RobSampson
ID: 33593301
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
 

Author Comment

by:rjthomes
ID: 33593487
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
 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
ID: 33593510
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
 

Author Comment

by:rjthomes
ID: 33601407
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
 

Author Comment

by:rjthomes
ID: 33601450
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Re-planning is just as important as planning. MS Project files need to be updated regularly to reflect the current status of the project and to streamline the upcoming tasks. We have seen a lot of issues where project managers have not updated the p…
Online collaboration is quickly becoming embedded in the workplace, and its benefits are tangible. See what the current landscape looks like and what the future holds for collaboration tools and the future of work.
It is a freely distributed piece of software for such tasks as photo retouching, image composition and image authoring. It works on many operating systems, in many languages.
Internet Business Fax to Email Made Easy - With eFax Corporate (http://www.enterprise.efax.com), you'll receive a dedicated online fax number, which is used the same way as a typical analog fax number. You'll receive secure faxes in your email, fr…

758 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

23 Experts available now in Live!

Get 1:1 Help Now