Solved

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

Posted on 2010-08-25
27
549 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 14
  • 13
27 Comments
 
LVL 65

Expert Comment

by:RobSampson
ID: 33527551
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
ID: 33528252
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
ID: 33528284
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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 65

Expert Comment

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

Author Comment

by:rjthomes
ID: 33551628
Rob,

What can I do to single out the problem line?

Chad
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 33556032
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
ID: 33558415
Rob,

Ok.  Here it is.

Chad
Untitled-3-copy.jpg
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 33563396
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
ID: 33563508
Rob,

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

No errors reported.

Chad
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 33563680
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
ID: 33564054
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
ID: 33564128
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
ID: 33572623
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
 
LVL 65

Expert Comment

by:RobSampson
ID: 33572876
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
ID: 33572881
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
ID: 33573062
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
ID: 33573156
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
ID: 33573194
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
ID: 33573738
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
ID: 33582658
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
ID: 33582694
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
ID: 33582711
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
ID: 33582728
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
ID: 33583211
Rob,

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

Chad
0
 

Author Comment

by:rjthomes
ID: 33583287
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
ID: 33583303
0
 
LVL 65

Expert Comment

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

What is SQL Server and how does it work?

The purpose of this paper is to provide you background on SQL Server. It’s your self-study guide for learning fundamentals. It includes both the history of SQL and its technical basics. Concepts and definitions will form the solid foundation of your future DBA expertise.

Question has a verified solution.

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

Read this checklist to learn more about the 15 things you should never include in an email signature.
A simple overview of the possibilities of using technology for project management.
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…
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…

691 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