Solved

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

Posted on 2010-09-03
13
2,446 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
[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
  • 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
Will your db performance match your db growth?

In Percona’s white paper “Performance at Scale: Keeping Your Database on Its Toes,” we take a high-level approach to what you need to think about when planning for database scalability.

 

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

Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

Question has a verified solution.

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

Lync meeting or Lync conferencing is what many organizations would like to deploy to allow them save money. But companies are now giving up for various reasons, one of which is that they cannot join external meetings (non-federated company meetings)…
Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
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…
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…
Suggested Courses

632 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