Solved

MS Project vba method to limit visible columns when printing gantt chart

Posted on 2010-09-03
13
2,313 Views
Last Modified: 2013-11-15
I have an existing script (Thanks Rob Sampson) that filters through resources and prints a gantt chart through vba macro.

I need to limit the field columns to Task, Duration And Start, plus the chart.

Page setup has a field to do this (I think) but nothing happens.

Anyway I would like to have the macro ensure that only these columns show up.

If I take the time each time I print to make sure the screen looks like image 81 everything works great.

But that is not likely.  I am in and out of the file multiple times a day and can't trust myself.

It would normally look something like image 80 when the macro is fired at night.

As I said, there is a setting in page setup (image 83) but it has no noticeable affect.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)



Sub PrintFilteredResourcesChanged()

    ' Macro PrintFilteredResources - loop on filters and then print

    ' $Id: PrintFilteredResources.txt,v 1.7 2000/08/23 23:24:10 phil Exp $

    ' Note: Ignores task dates that are 100% complete

    ' Todo: Handling multiple resource names better

    '       Select report from list instead of looping through them all

    On Error Resume Next                ' keep going on an error

    SelectBeginning                     ' restart from the beginning

    For Each Resource In ActiveProject.Resources

      If Resource.Work > 0 Then

        FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Baseline Start", Test:="does not equal", Value:="[Start]", ShowInMenu:=False, ShowSummaryTasks:=True

        FilterEdit Name:=Resource.Name, TaskFilter:=True, FieldName:="", NewFieldName:="Resource Names", Test:="contains", Value:=Resource.Name, Operation:="And", ShowSummaryTasks:=True

        FilterApply Name:=Resource.Name ' apply the filter

        If (Err.Number) Then            ' saw an error applying filter

            MsgBox "ERROR: " & Err.Description

            Err.Clear                   ' clear out the error

            GoTo NextResource           ' jump to the next resource

        End If

        Start = 0                       ' reset start date

        Finish = 0                      ' reset finish date

        SelectAll

        If (ActiveSelection = 0) Then

            GoTo NextResource

        End If

        For Each Task In ActiveSelection.Tasks

            'MsgBox "Checking task: " & Task.Name

             If Not (Task Is Nothing) Then

                 If (InStr(1, Task.ResourceNames, Resource.Name) And _

                    (Task.PercentComplete < 100)) Then

                    TryStart = Task.Start

                    TryFinish = Task.Finish

                    If (Start = 0) Then Start = TryStart    ' need a start date

                    If (Finish = 0) Then Finish = TryFinish ' need a finish date

                    ' see if we found an earlier start date / later finish date

                    If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart

                    If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish

                End If

            End If

        Next Task

        If (Start = 0) Then           ' no start date, nothing to see

            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name

            GoTo NextResource           ' jump to the next resource

        End If

        Start = DateAdd("d", -3, Start)                     ' adjust a few days

        Finish = DateAdd("d", 3, Finish)                    ' adjust a few days

                 

            ' generate and save seperate .pdf files for each resource thanks to RobSampson

                strFullName = ActiveProject.FullName

                strBaseName = Mid(strFullName, InStrRev(strFullName, "\") + 1)

                strBaseName = Left(strBaseName, InStrRev(strBaseName, ".") - 1)

                Set objShell = CreateObject("WScript.Shell")

                strMyDocs = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal")

                If Right(strMyDocs, 1) <> "\" Then strMyDocs = strMyDocs & "\"

                strSource = strMyDocs & strBaseName & ".pdf"

                strTarget = "C:\MyDocs\" & strBaseName & "_" & Resource.Name & ".pdf"

                FilePrintSetup "Adobe PDF"

                FilePrint FromDate:=Start, ToDate:=Finish

                Sleep 10000

                FileCopy strSource, strTarget

                ' Email variables:

                strTo = Resource.EMailAddress

                strSubject = "Subject Here"

                strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

                If strTo <> "" Then

                    SendEmailWithOutlook strSubject, strTo, strBody, strTarget

                Else

                    MsgBox "Unknown email address for resource: " & Resource.Name

                End If

      End If

NextResource:

    Next Resource

    FilterApply Name:="All Tasks"       ' apply the filter

End Sub



Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)

    Const olMailItem = 0

    Const olFormatPlain = 1

    On Error Resume Next

    boolOutlookOpen = True

    Set objOutlook = GetObject(, "Outlook.Application")

    If objOutlook Is Nothing Then

        Set objOutlook = CreateObject("Outlook.Application")

        objOutlook.Visible = True

        boolOutlookOpen = False

    End If

    Err.Clear

    Set objNameSpace = objOutlook.GetNamespace("mapi")

    Set objMailItem = objOutlook.CreateItem(olMailItem)

    With objMailItem

        .BodyFormat = olFormatPlain

        .To = strTo

        .Subject = strSubject

        .Body = strBody

        If strAttachment <> "" Then .Attachments.Add (strAttachment)

        .Send

        If Err.Number <> 0 Then MsgBox "Failed to send message. Error " & Err.Number & ": " & Err.Description

    End With

    If Err.Number = 0 Then

        objOutlook.sendandreceive False

    End If

    If Not boolOutlookOpen Then

        objOutlook.Quit

    End If

    Err.Clear

    On Error GoTo 0

End Sub

Open in new window

Untitled-81.jpg
Untitled-80.jpg
Untitled-83.jpg
0
Comment
Question by:rjthomes
  • 7
  • 6
13 Comments
 
LVL 65

Expert Comment

by:RobSampson
ID: 33608718
Hi, if you record a macro and follow the exact steps that you take to have it print correctly, what is the content of that macro?  Hopefully it would record the steps in details (some functions don't get recorded) and we can add that to the code.

Rob.
0
 

Author Comment

by:rjthomes
ID: 33608749
Rob,

I forgot to mention that I already did that.  It's empty.

Chad
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 33609227
Above this line:
                FilePrint FromDate:=Start, ToDate:=Finish

try adding this line:
                FilePageSetupView RepeatColums:=3

Regards,

Rob.
0
 

Author Comment

by:rjthomes
ID: 33614109
Rob,

It didn't seem to like it.  I wish I had some constructive input.

Thanks

Chad
Untitled-90.jpg
0
 

Author Comment

by:rjthomes
ID: 33614164
Rob,

Ok.  This works without the :

FilePageSetupView RepeatColums = 3

but nothing changes I still have more that three columns.

You would think that setting this in the page setup would create what I want but it does nothing.

Is it broke?

I actually tried this on another computer to check.  Same result.

Chad
CITRUSMASTERSCHEDULE-Rod.pdf
0
 

Author Comment

by:rjthomes
ID: 33614171
Rob,

When I said that it worked, I meant it did not generate an error.

Chad
0
U.S. Department of Agriculture and Acronis Access

With the new era of mobile computing, smartphones and tablets, wireless communications and cloud services, the USDA sought to take advantage of a mobilized workforce and the blurring lines between personal and corporate computing resources.

 
LVL 65

Expert Comment

by:RobSampson
ID: 33614216
Sorry, I didn't spell Columns right when I typed it in....try

FilePageSetupView RepeatColumns:=3

Regards,

Rob.
0
 

Author Comment

by:rjthomes
ID: 33614344
Rob,

No error but no change.

Chad
Untitled-91.jpg
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 33614361
Damn.....another thing I read was that you might be able to set up a custom view (table?) that lists the columns you want, then we could see if we can switch to that view (table?) and then print.....do you know how to do that?

Rob.
0
 

Author Comment

by:rjthomes
ID: 33614400
Rob,

I read something that hinted to that with very little info.

http://msdn.microsoft.com/en-us/library/bb221568(office.12).aspx

What did you read?

Chad
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 33614542
It was just a forum I found when trying to figure how to hide columns during printing:
http://forums.techarena.in/microsoft-project/1073042.htm

Regards,

Rob.
0
 

Author Comment

by:rjthomes
ID: 33614782
Rob,

Ok.  It was just that simple.

I created a couple custom views.

One for active use (&Gantt Chart) and one for printing (RJTSchedule).

Then I put

    ViewApply Name:="RJTSchedule"

before 'Select Beginning '

And

    ViewApply Name:="&Gantt Chart"

before 'End Sub'

It works great!!!

See the code below.

Thanks again!!!

Before I accept and close this, I am not done and haven't quite formulated my next question.  How can I make sure that you atleast see it?  I think you told me I just can't remember.

Chad
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)



Sub PrintFilteredResourcesChanged()

    ' Macro PrintFilteredResources - loop on filters and then print

    ' $Id: PrintFilteredResources.txt,v 1.7 2000/08/23 23:24:10 phil Exp $

    ' Note: Ignores task dates that are 100% complete

    ' Todo: Handling multiple resource names better

    '       Select report from list instead of looping through them all

    On Error Resume Next                ' keep going on an error

    ViewApply Name:="RJTSchedule"

    SelectBeginning                     ' restart from the beginning

    For Each Resource In ActiveProject.Resources

      If Resource.Work > 0 Then

        FilterEdit Name:=Resource.Name, TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Baseline Start", Test:="does not equal", Value:="[Start]", ShowInMenu:=False, ShowSummaryTasks:=True

        FilterEdit Name:=Resource.Name, TaskFilter:=True, FieldName:="", NewFieldName:="Resource Names", Test:="contains", Value:=Resource.Name, Operation:="And", ShowSummaryTasks:=True

        FilterApply Name:=Resource.Name ' apply the filter

        If (Err.Number) Then            ' saw an error applying filter

            MsgBox "ERROR: " & Err.Description

            Err.Clear                   ' clear out the error

            GoTo NextResource           ' jump to the next resource

        End If

        Start = 0                       ' reset start date

        Finish = 0                      ' reset finish date

        SelectAll

        If (ActiveSelection = 0) Then

            GoTo NextResource

        End If

        For Each Task In ActiveSelection.Tasks

            'MsgBox "Checking task: " & Task.Name

             If Not (Task Is Nothing) Then

                 If (InStr(1, Task.ResourceNames, Resource.Name) And _

                    (Task.PercentComplete < 100)) Then

                    TryStart = Task.Start

                    TryFinish = Task.Finish

                    If (Start = 0) Then Start = TryStart    ' need a start date

                    If (Finish = 0) Then Finish = TryFinish ' need a finish date

                    ' see if we found an earlier start date / later finish date

                    If (DateDiff("d", TryStart, Start) > 0) Then Start = TryStart

                    If (DateDiff("d", TryFinish, Finish) < 0) Then Finish = TryFinish

                End If

            End If

        Next Task

        If (Start = 0) Then           ' no start date, nothing to see

            'MsgBox "NOTE: No tasks found for resource: " & Resource.Name

            GoTo NextResource           ' jump to the next resource

        End If

        Start = DateAdd("d", -3, Start)                     ' adjust a few days

        Finish = DateAdd("d", 3, Finish)                    ' adjust a few days

                 

            ' generate and save seperate .pdf files for each resource thanks to RobSampson

                strFullName = ActiveProject.FullName

                strBaseName = Mid(strFullName, InStrRev(strFullName, "\") + 1)

                strBaseName = Left(strBaseName, InStrRev(strBaseName, ".") - 1)

                Set objShell = CreateObject("WScript.Shell")

                strMyDocs = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal")

                If Right(strMyDocs, 1) <> "\" Then strMyDocs = strMyDocs & "\"

                strSource = strMyDocs & strBaseName & ".pdf"

                strTarget = "C:\MyDocs\" & strBaseName & "_" & Resource.Name & ".pdf"

                FilePrintSetup "Adobe PDF"

                FilePrint FromDate:=Start, ToDate:=Finish

                Sleep 10000

                FileCopy strSource, strTarget

                ' Email variables:

                strTo = Resource.EMailAddress

                strSubject = "Subject Here"

                strBody = "Please find attached a copy of your resource schedule:" & vbCrLf

                If strTo <> "" Then

                    SendEmailWithOutlook strSubject, strTo, strBody, strTarget

                Else

                    MsgBox "Unknown email address for resource: " & Resource.Name

                End If

      End If

NextResource:

    Next Resource

    FilterApply Name:="All Tasks"                   ' apply the filter

        BaselineSave All:=True, Copy:=0, Into:=0    ' reset baseline

    ViewApply Name:="&Gantt Chart"

End Sub



Sub SendEmailWithOutlook(strSubject, strTo, strBody, strAttachment)

    Const olMailItem = 0

    Const olFormatPlain = 1

    On Error Resume Next

    boolOutlookOpen = True

    Set objOutlook = GetObject(, "Outlook.Application")

    If objOutlook Is Nothing Then

        Set objOutlook = CreateObject("Outlook.Application")

        objOutlook.Visible = True

        boolOutlookOpen = False

    End If

    Err.Clear

    Set objNameSpace = objOutlook.GetNamespace("mapi")

    Set objMailItem = objOutlook.CreateItem(olMailItem)

    With objMailItem

        .BodyFormat = olFormatPlain

        .To = strTo

        .Subject = strSubject

        .Body = strBody

        If strAttachment <> "" Then .Attachments.Add (strAttachment)

        .Send

        If Err.Number <> 0 Then MsgBox "Failed to send message. Error " & Err.Number & ": " & Err.Description

    End With

    If Err.Number = 0 Then

        objOutlook.sendandreceive False

    End If

    If Not boolOutlookOpen Then

        objOutlook.Quit

    End If

    Err.Clear

    On Error GoTo 0

End Sub

Open in new window

0
 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
ID: 33614861
Sure, that's great!  Nicely done.  When you are ready to post a new question, you can either click the "Ask a related question" link here just above the comments, or you can post a link to it here which I will also see.

Regards,

Rob.
0

Featured Post

Comprehensive Backup Solutions for Microsoft

Acronis protects the complete Microsoft technology stack: Windows Server, Windows PC, laptop and Surface data; Microsoft business applications; Microsoft Hyper-V; Azure VMs; Microsoft Windows Server 2016; Microsoft Exchange 2016 and SQL Server 2016.

Question has a verified solution.

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

As with any other System Center product, the installation for the Authoring Tool can be quite a pain sometimes. This article serves to help you avoid making these mistakes and hopefully save you a ton of time on troubleshooting :)  Step 1: Make sur…
This collection of functions covers all the normal rounding methods of just about any numeric value.
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …

867 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

16 Experts available now in Live!

Get 1:1 Help Now