asked on

I need some vba help to automatically email a pdf from ms project

I have a macro that loops through the available resources and generates a seperate pdf ghant chart for each (thanks to RobSampson).

Just before

FileCopy strSource, strTarget

I think is the appropriate place to do this before it gets renamed (could be wrong).

Any thoughts?

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
        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
            
      End If

Open in new window

RobSampson

Hi, hopefully the CDO message system will work for you.

Change the email variables in the code here, and see if it works. I have made it attached the renamed PDF.

Regards,

Rob.

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
        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:
				strServer = "mailhost.abc.com"
				strTo = "john.doe@abc.com"
				strFrom = "john.doe@abc.com"
				strSubject = "Subject Here"
				strBody = "Please find attached a copy of your resource schedule:" & VbCrLf

				SendEmail strServer, strTo, strFrom, strSubject, strBody, strTarget

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

Public Sub SendEmail(strServer, strTo, strFrom, strSubject, strBody, strAttachment)
        Dim objMessage
        
        Set objMessage = CreateObject("CDO.Message")
        objMessage.To = strTo
        objMessage.From = strFrom
        objMessage.Subject = strSubject
        objMessage.TextBody = strBody
 		If strAttachment <> "" Then objMessage.AddAttachment strAttachment
        '==This section provides the configuration information for the remote SMTP server.
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        'Name or IP of Remote SMTP Server
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strServer
        'Server port (typically 25)
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25      
        objMessage.Configuration.Fields.Update
        '==End remote SMTP server configuration section==
 
        objMessage.Send
        Set objMessage = Nothing
End Sub

Open in new window

RobSampson

Here's some code I grabbed from somewhere else that will hopefully use Outlook to send the message. You will need your client to be enabled for relay by the SMTP server to use the CDO method.

Regards,

Rob.

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
        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 = "chad@rjthomes.com"
                strSubject = "Subject Here"
                strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

                SendEmailWithOutlook strSubject, strTo, strBody, strTarget

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

Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)
	Dim objOutlook
	Const MAILITEM = 0
	Const IMPORTANCENORMAL = 1
	Set objOutlook = CreateObject("Outlook.Application")
	objOutlook.Visible = True
	Set objMessage = objOutlook.CreateItem(MAILITEM)
	With objMessage
		.Recipients.Add(strTo)
		.Subject = strSubject
		.Importance = IMPORTANCENORMAL
		.Body = strBody
		.Attachments.Add(strAttachment)
		.Send
	End With
	Set objMessage = Nothing
	Set objOutlook = Nothing
End Sub

Open in new window

rjthomes

ASKER

I know basically what 'You will need your client to be enabled for relay by the SMTP server to use the CDO method.' means but do not know how to do it.

I went ahead and ran it here is the error.

Thanks

Chad
Untitled-14.jpg

RobSampson

"Object doesn't support this property or method"....any idea which line is causing this error?

rjthomes

ASKER

Rob,

What can I do to single out the problem line?

Chad

RobSampson

If you comment out the line
On Error Resume Next

you should get a "Debug" button, which will highlight the problem line.

Regards,

Rob.

rjthomes

ASKER

Rob,

Ok. Here it is.

Chad
Untitled-3-copy.jpg

RobSampson

OK, try this. I have used a different SendEmailWithOutlook sub. In there, there is still
objOutlook.Visible = True

but if that causes a problem again, just comment it out, and see how it goes.

Regards,

Rob.

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
        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 = "chad@rjthomes.com"
                strSubject = "Subject Here"
                strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

                SendEmailWithOutlook strSubject, strTo, strBody, strTarget

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

rjthomes

ASKER

Rob,

Ok... It is sending an email to me but with no attachment.

No errors reported.

Chad

RobSampson

Oh whoops! Forgot the attachment....

Under this line:
.Body = strBody

add this line:
If strAttachment <> "" Then .Attachments.Add(strAttachment)

Regards,

Rob.

rjthomes

ASKER

Rob,

Ok. That is the stuff.

How do we change

strTo = "chad@rjthomes.com"

to be the email address of the corresponding resource?

Chad

RobSampson

Do you mean like
<resourcename>@rjthomas.com

If so, just change
strTo = "chad@rjthomes.com"

to
strTo = Resource.Name & "@rjthomes.com"

Regards,

Rob.

rjthomes

ASKER

Rob,

I am having a hard time identifying the correct syntax.

strTo = Resource.Email_Address

Is not working.

The field is identified in the image below.

[Email Address]

I don't know what to do with the space or what else to try.

I just realized something new.

The macro cycles through all of the tasks identifying the resources used for each. It then uses a filter that corresponds to that resource to print out a filtered report. Duh!!!

The problem is that if I have not pre configured a filter that matches the name of the resource (exactly) it comes back with the error below and stalling the macro.

I wish it would filter and report without the need of a filter or maybe dynamically/temporarily create the filter .

I am not trying to get off track and this may be for another question but just wanted to bring it up.

Anyway I appreciate your continued effort.

Thanks.

Chad
Untitled-20.jpg
Untitled-21.jpg
Untitled-22.jpg
Untitled-23.jpg

RobSampson

OK, from here:
http://msdn.microsoft.com/en-us/library/aa679947(v=office.11).aspx

it looks like the email address property is called
Resource.EMailAddress

As far as automatically creating a filter goes....try recording a macro (via Tools --> Macro --> Record Macro), create your filter, click Tools --> Macro --> Stop Recording, then press ALT + F11 to open the VBE, find that macro, and see if the code will show you how it's created.

Then we might be able to get the filter created and applied automatically.

Regards,

Rob.

RobSampson

Sorry, here is some slightly updated code, with the emailAddress property, and a check to see if there actually is a "To" address.

Regards,

Rob.

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

rjthomes

ASKER

Rob,

Wow!!!!

The email is working great now. I am not sure what other changes you made but I think we are headed in a good direction.

I noticed that if a resource does not have an assignment I get the error below.

The error about the missing filter remains.

Any thoughts?

Chad
Untitled-30.jpg
Untitled-31.jpg

RobSampson

Both errors relate to a filter missing don't they? Did you record a macro to create a filter for me to look at? I don't have my Project test machine in front of me today....

Rob.

rjthomes

ASKER

Oh yeh.

Here is the macro.

I think the error about no task found means the resource exists but no work was assigned to it.

Chad

Sub Macro1()
' Macro Macro1
' Macro Recorded Tue 8/31/10 by Chad.
    FilterEdit Name:="Filter 1", TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Resource Names", Test:="equals", Value:="test", ShowInMenu:=False, ShowSummaryTasks:=False
    FilterApply Name:="All Tasks"
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

RobSampson

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

rjthomes

ASKER

Rob,

Ok. The macro creates the filter like a champ but......

new problem. I will try to explain.

Untitled-40.jpg
Untitled-41.jpg

rjthomes

ASKER

I wasn't quite done with the above so I will continue.

I am getting the error that appears in image 41. I think it has to do with tasks that have multiple resources assigned (which I need, see image 41, item #44).

As I said it is creating the filter perfect but when I look at the filter (for instance GE). nothing comes up.

If I run a filter (seen in image 42 and 43) it lets me pick a resource (one time) and that filter works great.

This has something to do with what table the filter is using. I think the way we were headed looks at the task list and if the task has a single resource the filter works great.

The filter from image 42 and 43 seems to look at the resource table.

I am still trying to get my head around it.

Any thoughts.

Chad
Untitled-42.jpg
Untitled-43.jpg

rjthomes

ASKER

Rob,

It appears that if I make sure that each task has only one resource then the error does not occur. I am glad I tested this but wish I didn't have to be such a pain in your side.

A lot of tasks will have several resources.

Chad

RobSampson

OK, so I'm not that familiar with Project, but for a task, do you want to filter on those multiple resources all at once, or each resource for that task?

Either way, can you record a macro in which you create a filter that works on such a task, and show me that code?

Regards,

Rob.

rjthomes

ASKER

Rob,

OK. OK. OK. it's my fault I will explain in a minute.

Chad

rjthomes

ASKER

Rob,

It works!!!!!!!!

When I recorded that macro for you to use I set the test as "exactly". It needed to be "contains"

FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Resource Names", Test:="contains", Value:=Resource.Name, ShowInMenu:=False, ShowSummaryTasks:=True

This line re-creates each filter each time so this was actually a problem for everything.

My fault..

This is exactly what I wanted. We did it (I mean you).

Anyway.

This is the final code for the question.

I have a few more features that I want to add in another question. I like to see you get more points.

I am going to go set up the question and place the link in the comments.

Thanks again!!!!!!!

Chad

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

rjthomes

ASKER

Rob,

I hope you will join me. This should be an easy one.

https://www.experts-exchange.com/questions/26446214/Ms-Project-vba-that-creates-filter-for-tasks-that-differ-from-baseline.html

Chad

RobSampson

That's great Chad. Thanks for sorting that out....

I'll take a look at your other question when I get some time...

Rob.