|
Sub Main()
Dim objproject, objmilestones, tasks, T
As Object
'Create the Milestones object
Set objmilestones = CreateObject("Milestones")
'Create the MS Project object
Set objproject = GetObject("c:\test\projectexample.mpp")
'Create the tasks object
Set tasks = objproject.tasks
If tasks.Count < 1 Then
MsgBox "No tasks in project file"
End
End If
'Start Milestones
objmilestones.Activate
'Set Schedule start and end dates
objmilestones.SetStartDate objproject.Start
objmilestones.SetEndDate objproject.Finish
'Format the schedule
'first, make sure there are no columns
For x = 1 To 10
objmilestones.SetColumnWidth x, 0#
Next x
'set up one column on the left side of
the schedule
objmilestones.SetColumnWidth 1, 2.5
'it will be outlined, so set the amount to indent for each outline level
objmilestones.SetColumnProperty 1,
"Indent", 0.2
'make it left-justified
objmilestones.SetColumnProperty 1, "TextAlign",
0
'add a column heading
objmilestones.SetColumnProperty 1,
"ColumnHeadingLine1", "Task"
objmilestones.SetColumnProperty 1,
"ColumnHeadingLine2", "Name"
'set up date headings
objmilestones.SetDateHeading 1,
"Yearly", 1
objmilestones.SetDateHeading 2,
"Monthly", 4
objmilestones.SetDateHeading 3,
"None", 0
objmilestones.SetDateHeading 4,
"None", 0
'we will have 22 tasks on each page
objmilestones.SetLinesPerPage 22
'add a curtain to shade the first 15
days of January
objmilestones.AddCurtain
"01/01/1999", "01/15/1999"
objmilestones.SetCurtainProperties 1,
"01/01/1999", "01/15/1999", 2, 4, 8, 0
'Add titles using information in MS
Project file
objmilestones.SetTitle1 "Title: " +
objproject.Title
objmilestones.SetTitle2 "Subject: " +
objproject.Subject
objmilestones.SetTitle3 "Author: " +
objproject.Author
'set up the symbology for summary tasks
objmilestones.SetToolboxSymbolProperty 1,
"Type", 40 'triangle
objmilestones.SetToolboxSymbolProperty 1,
"DatePosition", 13 'hide
objmilestones.SetToolboxSymbolProperty 1,
"FillColor", 18 'black
objmilestones.SetToolboxHorizontalConnectorProperty
1, "Type", 20 'Upper bar
objmilestones.SetToolboxHorizontalConnectorProperty
1, "FillColor", 18 'Black
'set up the symbology for non-summary
tasks
objmilestones.SetToolboxSymbolProperty 3,
"Type", 45 'circled triangle-small
objmilestones.SetToolboxSymbolProperty 3,
"DatePosition", 13 'hide
objmilestones.SetToolboxHorizontalConnectorProperty
2, "Type", 20 'Upper bar
objmilestones.SetToolboxHorizontalConnectorProperty
2, "FillColor", 4 'Blue
objmilestones.SetToolboxHorizontalConnectorProperty
2, "ShadowColor", 7 'Gray
'set up symbology for critical tasks
objmilestones.SetToolboxHorizontalConnectorProperty
3, "Type", 20 'Upper bar
objmilestones.SetToolboxHorizontalConnectorProperty
3, "FillColor", 6 'Red
objmilestones.SetToolboxSymbolProperty 5,
"Type", 40 'triangle
objmilestones.SetToolboxSymbolProperty 5,
"DatePosition", 13 'hide
objmilestones.SetToolboxSymbolProperty 5,
"FillColor", 6 'Red
'set up symbology for one-day events
(milestones)
objmilestones.SetToolboxSymbolProperty 7,
"Type", 3
objmilestones.SetToolboxSymbolProperty 7,
"FillColor", 1 'Aqua
'set up the legend
objmilestones.SetLegendHeight 1#
objmilestones.SetLegendProperty "entriesperrow",
3
objmilestones.SetLegendSymbology 1, 1, 1, 1 '
summary
objmilestones.SetLegendText 1,
"Summary", ""
objmilestones.SetLegendText 2,
"Planned", ""
objmilestones.SetLegendText 3,
"Critical", ""
objmilestones.SetLegendSymbology 2, 3, 2, 3
'planned
objmilestones.SetLegendSymbology 3, 5, 3, 5
'critical
'loop through the list of MS Project
tasks and build
'Milestones schedule
currentrow = 0
For Each T In tasks
currentrow = currentrow + 1
objmilestones.settasklinegrid
currentrow, 0, 7, 0
objmilestones.settasklinegrid
currentrow, 1, 7, 1
If T.Summary = True Then
symboltype = 1
connectortype = 1
Else
symboltype = 3
connectortype = 2
End If
If T.Critical = True Then
symboltype = 5
connectortype = 3
End If
'add text to the task name column
objmilestones.PutCell currentrow, 1, T.Name
If Format(T.Start, "MM/DD/YY")
= Format(T.Finish, "MM/DD/YY") Then
'single day milestones
objmilestones.addsymbol currentrow,
Format(T.Finish, "MM/DD/YY"), 7
If T.Critical Then objmilestones.SetSymbolProperty
currentrow, 1, "FillColor", 6
Else
'add start+finish dates
objmilestones.addsymbol currentrow,
Format(T.Start, "MM/DD/YY"), symboltype, connectortype, 2
objmilestones.addsymbol currentrow,
Format(T.Finish, "MM/DD/YY"), symboltype
If T.Critical = True Then
'color critical symbols red
objmilestones.SetSymbolProperty currentrow, 1,
"FillColor", 6
objmilestones.SetSymbolProperty currentrow, 2,
"FillColor", 6
'shade the critical tasks
objmilestones.settasklineshade currentrow, 0,
15
objmilestones.settasklineshade currentrow, 1,
15
End If
End If
'set the outline level
objmilestones.setoutlinelevel currentrow,
T.Outlinelevel
'set the font size
objmilestones.settasklinefontheight currentrow,
10
'display a message in the status bar
objmilestones.setstatusmessage "Task:
" + Str(currentrow)
Next T
'keep the schedule open
objmilestones.KeepScheduleOpen
'Maximize the Milestones window
objmilestones.MaximizeWindow
Exit Sub
End Sub
|
