Solved

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

Posted on 2010-08-25
27
474 Views
Last Modified: 2013-11-15
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

0
Comment
Question by:rjthomes
  • 14
  • 13
27 Comments
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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

0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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

0
 

Author Comment

by:rjthomes
Comment Utility
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
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
"Object doesn't support this property or method"....any idea which line is causing this error?
0
 

Author Comment

by:rjthomes
Comment Utility
Rob,

What can I do to single out the problem line?

Chad
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
If you comment out the line
On Error Resume Next

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

Regards,

Rob.
0
 

Author Comment

by:rjthomes
Comment Utility
Rob,

Ok.  Here it is.

Chad
Untitled-3-copy.jpg
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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

0
 

Author Comment

by:rjthomes
Comment Utility
Rob,

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

No errors reported.

Chad
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Oh whoops!  Forgot the attachment....

Under this line:
            .Body = strBody

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


Regards,

Rob.
0
 

Author Comment

by:rjthomes
Comment Utility
Rob,

Ok.  That is the stuff.  

How do we change

strTo = "chad@rjthomes.com"

to be the email address of the corresponding resource?

Chad
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Do you mean like
<resourcename>@rjthomas.com

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

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


Regards,

Rob.
0
 

Author Comment

by:rjthomes
Comment Utility
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
0
What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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.
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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

0
 

Author Comment

by:rjthomes
Comment Utility
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
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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.
0
 

Author Comment

by:rjthomes
Comment Utility
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

0
 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
Comment Utility
I just noticed that "No tasks found for resource" is a custom message given by this bit:

        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

so if you don't want to see that message, just comment out that message box I suppose.

The macro looks promising.  I have added this line to the code:

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

to (hopefully) create the resource with the filter against "Resource Names"

Test it out by deleting a manually created filter and see what happens.  If you get any errors, comment out
On Error Resume Next
again, just to see what line it's on.

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

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

        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
 

Author Comment

by:rjthomes
Comment Utility
Rob,

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

new problem.  I will try to explain.


Untitled-40.jpg
Untitled-41.jpg
0
 

Author Comment

by:rjthomes
Comment Utility
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
0
 

Author Comment

by:rjthomes
Comment Utility
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
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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.
0
 

Author Comment

by:rjthomes
Comment Utility
Rob,

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

Chad
0
 

Author Comment

by:rjthomes
Comment Utility
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

0
 

Author Comment

by:rjthomes
Comment Utility
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
That's great Chad.  Thanks for sorting that out....

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

Rob.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Create high volume marketing opportunities using email signatures with these top 10 DOs and DON'Ts of email signature marketing.
Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

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

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

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now