Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

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

Posted on 2010-09-03
13
Medium Priority
?
2,512 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
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 

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

NFR key for Veeam Agent for Linux

Veeam is happy to provide a free NFR license for one year.  It allows for the non‑production use and valid for five workstations and two servers. Veeam Agent for Linux is a simple backup tool for your Linux installations, both on‑premises and in the public cloud.

Question has a verified solution.

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

"Disruption" is the most feared word for C-level executives these days. They agonize over their industry being disturbed by another player - most likely by startups.
Learn how ViaSat reduced average response times for IT incidents from 10 minutes to 30 seconds.
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
If you’ve ever visited a web page and noticed a cool font that you really liked the look of, but couldn’t figure out which font it was so that you could use it for your own work, then this video is for you! In this Micro Tutorial, you'll learn yo…

772 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