Solved

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

Posted on 2010-09-03
13
2,286 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
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 
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

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.

Join & Write a Comment

MS Access 2003 or later To MySQL Migration Project Hello All, this is my second article in the category of MS-OFFICE Automation. In internet I am not able to find any comprehensive resource on the Migration of MS Access back-end to MySQL so I fin…
Not long ago I saw a question in the VB Script forum that I thought would not take much time. You can read that question (Question ID  (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28455246.html)28455246) Here (http…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…

706 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

19 Experts available now in Live!

Get 1:1 Help Now