Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

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

Posted on 2010-09-01
20
Medium Priority
?
3,247 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
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
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
 
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 2000 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

Featured Post

How to Use the Help Bell

Need to boost the visibility of your question for solutions? Use the Experts Exchange Help Bell to confirm priority levels and contact subject-matter experts for question attention.  Check out this how-to article for more information.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

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…
Article by: x-men
Where used to see Gantt charts for illustrating project timelines, but what if I wanted to visualize passed timed events? Here's how.
Exchange organizations may use the Journaling Agent of the Transport Service to archive messages going through Exchange. However, if the Transport Service is integrated with some email content management application (such as an anti-spam), the admin…
Is your OST file inaccessible, Need to transfer OST file from one computer to another? Want to convert OST file to PST? If the answer to any of the above question is yes, then look no further. With the help of Stellar OST to PST Converter, you can e…

783 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