rjthomes
asked on
Ms Project vba that creates filter for tasks that differ from baseline
I have the script below that was largely created by Rob Sampson (Thank you).
I need to add a variable that identifies tasks that have different start dates than the baseline.
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
ASKER
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
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
Untitled-40.jpg
ASKER
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
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
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.
If you need to query both filters separately, we might need to add a loop to go through both filters after applying them...
Rob.
>> would identify the absence of work and send it to the next resource
Yes, I would have thought so....does it not?
Yes, I would have thought so....does it not?
ASKER
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
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
Untitled-60.jpg
ASKER
Rob,
I also noticed that line 13 has
OverwriteExisting:=True
but line 14 does not.
Chad
I also noticed that line 13 has
OverwriteExisting:=True
but line 14 does not.
Chad
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.
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.
ASKER
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
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
ASKER
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
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
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.
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
ASKER
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
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
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.
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.
ASKER
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
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
ASKER
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
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
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.
On Error Resume Next
so we can pinpoint where it's causing an error, and work on that part....
Rob.
ASKER
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
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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
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
ASKER
Rob,
Here is that link.
https://www.experts-exchange.com/questions/26451518/MS-Project-vba-method-to-limit-visible-columns-when-printing-gantt-chart.html
Thank you so much!!!!
Chad
Here is that link.
https://www.experts-exchange.com/questions/26451518/MS-Project-vba-method-to-limit-visible-columns-when-printing-gantt-chart.html
Thank you so much!!!!
Chad
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.