MEET FEATURE REQUIREMENTS, SCHEDULE, and BUDGET! Consulting available to teach your organization to apply this methodology and tools for powerful quantitative management of your business processes.
- Instruction of your staff at your site, using courseware, application example, and a functional template.
- Mentoring your key staff on an ongoing or periodic basis, on these tools or on Quantitative Program Management.
- Contracting or Employment in your organization on specific topics.
Check out my YouTube Channel: Power Operational Intelligence
Now Live! Overview, Structure, Task Data, Table Design, SQL Server, and Re-Linking now showing.
Video courses covering material on this website, and more, are presented in the playlists.
Code snippet links at YouTube Code Snippets. Twitter at @poweroperation1, #poweropi, #poweroperationalintelligence.
Subscribe on YouTube, and click the "Notification" Bell icon to be notified as content is published.
Microsoft Project Task Data ExportThe following VB code exports task data from MSProject to an Excel file. To use the code, copy from this text file.
References
Option Explicit
Public Sub ReportDatesExport()
'Copyright (c) 2013 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice.
'Runs with "ctl-t" from MSProject UI.
Dim thisProject As Project
Dim fileName As String, filePath As String, mapName As String, meFileName As String
Dim msgBoxResponse As VbMsgBoxResult
Set thisProject = ActiveProject
fileName = thisProject.Name
filePath = thisProject.Path
fileName = Left(fileName, InStrRev(fileName, ".", , vbTextCompare) - 1)
'OPTIONAL: warn the user if exporting from a non-rollup project, and allow them to abort
' the operation.
If InStr(1, LCase(fileName), "rollup", vbTextCompare) <= 0 Then
msgBoxResponse = MsgBox("Export from Rollup. Click Ok to continue anyway, _
Cancel to abort.", vbOKCancel, "Export Rollup")
If msgBoxResponse = vbCancel Then Exit Sub
End If
'NOTE: the export will be into a file called <filename>.xlsx, similar to the <filename>.mpp you are
'exporting. The export will be in the same directory as the .mpp you are exporting.
'You will need to import this filename to use the data.
mapName = "ReportDatesExport"
createMap mapName:=mapName
FileSaveAs Name:=filePath & "/" & fileName & ".xlsx", FormatID:="MSProject.ACE", map:=mapName
'FileSaveAs Name:=filePath & "/" & fileName & ".xls", FormatID:="MSProject.XLS5", map:=mapName
End Sub
Sub createMap(ByVal mapName As String)
'Copyright (c) 2013 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice.
MapEdit Name:=mapName, Create:=True, OverwriteExisting:=True, DataCategory:=pjMapTasks, _
CategoryEnabled:=True, TableName:="Task_Table1", FieldName:="Name", _
ExternalFieldName:="Name", HeaderRow:=True, AssignmentData:=False, TextFileOrigin:=0, _
UseHtmlTemplate:=False, IncludeImage:=False
MapEdit Name:=mapName, DataCategory:=pjMapTasks, FieldName:="Start", _
ExternalFieldName:="Start_Date"
MapEdit Name:=mapName, DataCategory:=pjMapTasks, FieldName:="Finish", _
ExternalFieldName:="Finish_Date"
MapEdit Name:=mapName, DataCategory:=pjMapTasks, FieldName:="Notes", _
ExternalFieldName:="Notes"
MapEdit Name:=mapName, DataCategory:=pjMapTasks, FieldName:="UniqueID", _
ExternalFieldName:="UniqueID"
End Sub
Visio .mpp PresentationThe following VB code displays exported MSProject task data as bars in a Visio doc. To use the code, copy from this text file. Link Visio2010 External Data to Excel export file from Microsoft Project.
In Visio2010, insert a timeline object on a page (from Timeline Shapes) and configure it. In Visio2010, a insert a Block Interval or Diamond Milestone on the page. In Visio2010, show the External Data pane along with the Drawing pane. In the External Data, scroll to the desired task and drag from it to the Block Interval or Diamond Milestone to create a link. The following code will position the Diamond Milestone to the Start Date of the linked task, or size and position the Block Interval properly relative to the dates shown for the Timeline Shape in the drawing. A task shape rectangle with a start date or end date outside the start and end dates of the timeline onthe page is truncated to that end date, and the shape outline will be shown as a dashed line. A task shape rectangle completely outside the timeline will be hidden.
In Visio2010 Modules: Module1
Option Explicit
Dim inchesPerDay As Double
Public Sub setupShapes()
'Copyright (c) 2012 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice.
Dim thisPage As Page
Dim shapeVar As Variant
Dim thisShape As Shape
Dim cellValue As Variant, cellValueW As Variant, cellVisMilestoneStart As Variant
Dim cellStartDate As String, cellFinishDate As String, cellName As String, cellUniqueID As String
Dim setLeft As String, setWidth As String, setHeight As String
Dim cellLookFor As String, temp As String, tempTest As String
Dim dateStart As Date, dateEnd As Date, dateStartLocal As Date, dateFinishLocal As Date
Dim dateTest As Date
Dim dimLeft As Double, dimRight As Double, dimTotal As Double, dimLeftLocal As Double
Dim dimWidthLocal As Double, dimWidth As Double
Dim gotLeft As Boolean, gotRight As Boolean
Dim dateRange As Double, widthTest As Double, testDbl As Double
Dim vsoDataRecordset As Visio.DataRecordset
Dim intDataRecordsetCount As Integer, thisDataRecordsetNumber As Integer
'Refresh the DataRecordset
intDataRecordsetCount = ActiveDocument.DataRecordsets.Count
For thisDataRecordsetNumber = 1 To intDataRecordsetCount
Set vsoDataRecordset = ActiveDocument.DataRecordsets(thisDataRecordsetNumber)
vsoDataRecordset.Refresh
Next thisDataRecordsetNumber
Set thisPage = ActivePage
cellStartDate = "Prop._VisDM_Start_Date"
cellFinishDate = "Prop._VisDM_Finish_Date"
cellName = "Prop._VisDM_Name"
cellUniqueID = "Prop._VisDM_UniqueID"
cellVisMilestoneStart = "User.visMilestoneDate"
gotLeft = False
gotRight = False
'Get timeline Start and End dates from timeline object
For Each shapeVar In thisPage.Shapes
Set thisShape = shapeVar
If InStr(1, thisShape.NameU, "timeline", vbTextCompare) > 0 Then
'When a timeline shape is found, associate start and end dates with
'physical size and placement of the timeline object.
cellValue = ""
cellValueW = ""
If thisShape.CellExists("User.visBeginDate", True) Then dateStart = _
thisShape.Cells("User.visBeginDate").Formula
If thisShape.CellExists("User.visEndDate", True) Then dateEnd = _
thisShape.Cells("User.visEndDate").Formula
If thisShape.CellExists("BeginX", True) Then cellValue = thisShape.Cells("BeginX")._
Formula
If thisShape.CellExists("EndX", True) Then cellValueW = thisShape.Cells("EndX")._
Formula
If cellValue <> "" And cellValueW <> "" Then
cellValue = Trim(Left(cellValue, Len(cellValue) - 3))
cellValueW = Trim(Left(cellValueW, Len(cellValueW) - 3))
dimLeft = CSng(cellValue)
dimRight = CSng(cellValueW)
gotLeft = True
gotRight = True
Exit For
End If
End If
Next shapeVar
If gotLeft And gotRight Then
dateRange = CDbl(dateEnd - dateStart + 1)
dimTotal = dimRight - dimLeft
inchesPerDay = CDbl(dimTotal / dateRange)
'Scan all shapes, and place the ones that are linked to schedule data. Set width
' to match duration (finish date - start date). Determine midpoint date given the
' duration and start date, and set PinX to locate the shape along the timeline.
For Each shapeVar In thisPage.Shapes
Set thisShape = shapeVar
cellValue = thisShape.Characters
'If it's linked to the data from the mpp, a shape will have a UniqueID cell specifying
'the UniqueID of the mpp task to which it is linked, as well as cells for start and
'end dates for the task.
If thisShape.CellExists(cellUniqueID, True) Then
'If it's a shape linked to the import data file, then get the start and end dates
' from the linkage.
If thisShape.CellExists(cellStartDate, True) Then dateStartLocal = _
DateValue(formulaStringToString(thisShape.Cells(cellStartDate).Formula))
If thisShape.CellExists(cellFinishDate, True) Then dateFinishLocal = _
DateValue(formulaStringToString(thisShape.Cells(cellFinishDate).Formula))
'If it's a milestone shape: Milestone date is taken from the Start date of a task,
' so set it that way to be sure its displayed position and width are correct.
If thisShape.CellExists(cellVisMilestoneStart, True) Then _
dateFinishLocal = dateStartLocal
'If shape is completely outside the timeline, just hide the shape.
If dateStartLocal >= dateEnd Or dateFinishLocal <= dateStart Then
'Put the shape at the timeline limit so that it won't invoke an adjacent page.
If dateStartLocal >= dateEnd Then
dateStartLocal = dateEnd
dateFinishLocal = dateStartLocal
End If
If dateFinishLocal <= dateStart Then
dateFinishLocal = dateStart
dateStartLocal = dateFinishLocal
End If
'Hide the shape or milestone...
If thisShape.CellExists(cellVisMilestoneStart, True) Then
'Hide Milestone
'Not clear how to hide a milestone... the following do not work
' thisShape.Cells("Transparency").Formula = "100%"
' thisShape.Cells("LineColorTrans").Formula = "100%"
' thisShape.Cells("FillForegndTrans").Formula = "100%"
' thisShape.Cells("FillBkgndTrans").Formula = "100%"
' thisShape.Cells("HideText").Formula = "True"
Else
'Hide Shape
thisShape.Cells("Geometry1.NoShow").Formula = "True"
thisShape.Cells("HideText").Formula = "True"
End If
'Otherwise show the shape, with appropriate modifiers.
Else
'Show the shape or milestone...
If thisShape.CellExists(cellVisMilestoneStart, True) Then
'Show Milestone
'Not clear how to show a milestone... the following do not work
' thisShape.Cells("Transparency").Formula = "0%"
' thisShape.Cells("LineColorTrans").Formula = "0%"
' thisShape.Cells("FillForegndTrans").Formula = "0%"
' thisShape.Cells("FillBkgndTrans").Formula = "0%"
' thisShape.Cells("HideText").Formula = "False"
Else
'Show Shape
thisShape.Cells("Geometry1.NoShow").Formula = "False"
thisShape.Cells("HideText").Formula = "False"
End If
'If shape extends outside timeline, make the outline "dashed"
If dateStartLocal < dateStart Or dateFinishLocal > dateEnd Then
'If shape extends beyond limits of the timeline...
'If it's not a milestone, make outline dashed.
If Not thisShape.CellExists(cellVisMilestoneStart, True) Then _
thisShape.Cells("LinePattern").Formula = "2"
Else
'If it's not a milestone, make outline a solid line.
If Not thisShape.CellExists(cellVisMilestoneStart, True) Then _
thisShape.Cells("LinePattern").Formula = "1"
End If
'If shape extends beyond timeline start, truncate the start of the task
' to the milestone start.
If dateStartLocal < dateStart Then
dateStartLocal = dateStart
If thisShape.CellExists(cellVisMilestoneStart, True) Then
'If it's a milestone, keep the start and end dates consistent.
dateFinishLocal = dateStart
End If
End If
'If shape extends beyond timeline end, truncate the end of the task to the
' milestone end.
If dateFinishLocal > dateEnd Then
dateFinishLocal = dateEnd
If thisShape.CellExists(cellVisMilestoneStart, True) Then
'If it's a milestone, keep the start and end dates consistent.
dateStartLocal = dateEnd
End If
End If
End If
'Set the shape dimensions and position to match its net start and end dates.
dimWidth = CDbl(dateFinishLocal - dateStartLocal + 1) * inchesPerDay
setWidth = formatInches(dimWidth)
'testDbl = CDbl(Left(setWidth, Len(setWidth) - 3)) / inchesPerDay
setLeft = formatInches(dimLeft + dimWidth / 2 + _
daysToInches(CDbl(dateStartLocal - dateStart + 1)))
'dateTest = dateStart + (CDbl(Left(setLeft, Len(setLeft) - 3)) - _
dimLeft) / inchesPerDay
setHeight = "0.25 in"
'Cells are set as strings, so they have to be formatted properly.
thisShape.Cells("PinX").Formula = stringToFormulaForString(setLeft)
thisShape.Cells("Width").Formula = stringToFormulaForString(setWidth)
thisShape.Cells("Height").Formula = stringToFormulaForString(setHeight)
'If shape is a milestone, set the visible date.
If thisShape.CellExists(cellVisMilestoneStart, True) Then _
thisShape.Cells(cellVisMilestoneStart) = _
DateValue(formulaStringToString(thisShape.Cells(cellStartDate)._
Formula))
End If
Next shapeVar
End If
End Sub
Public Sub updatePath()
'Copyright (c) 2012 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice.
Dim vsoDataRecordset As Visio.DataRecordset
Dim thisDataConnection As DataConnection
Dim intDataRecordsetCount As Integer, thisDataRecordsetNumber As Integer
Dim thisPath As String, thisFileName As String
'Refresh the DataRecordset
intDataRecordsetCount = ActiveDocument.DataRecordsets.Count
For thisDataRecordsetNumber = 1 To intDataRecordsetCount
Set vsoDataRecordset = ActiveDocument.DataRecordsets(thisDataRecordsetNumber)
Set thisDataConnection = vsoDataRecordset.DataConnection
thisFileName = thisDataConnection.FileName
If InStr(1, thisFileName, "netapp12a", vbTextCompare) Then
thisFileName = Replace(thisFileName, "netapp12a", "netapp24a")
'thisDataConnection.FileName = thisFileName
End If
thisPath = thisDataConnection.ConnectionString
If InStr(1, thisPath, "netapp12a", vbTextCompare) Then
thisPath = Replace(thisPath, "netapp12a", "netapp24a")
thisDataConnection.ConnectionString = thisPath
End If
vsoDataRecordset.Refresh
Next thisDataRecordsetNumber
End Sub
Private Function stringToFormulaForString(strIn As String) As String
Dim strResult As String
On Error GoTo stringToFormulaForString_Err
strResult = strIn
strResult = Replace(strResult, Chr(34), Chr(34) & Chr(34))
strResult = Chr(34) & strResult & Chr(34)
stringToFormulaForString = strResult
Exit Function
stringToFormulaForString_Err:
Debug.Print Err.Description
End Function
Private Function formulaStringToString(strFormula As String) As String
Const ONE_QUOTE As String = """"
Const TWO_QUOTES As String = """"""
Dim strConvertedFormula As String, strFirstCharacter As String
Dim strLastCharacter As String, intStringLength As Integer
On Error GoTo formulaStringToString_Err
strConvertedFormula = strFormula
intStringLength = Len(strFormula)
strFirstCharacter = Mid(strFormula, 1, 1)
strLastCharacter = Mid(strFormula, intStringLength, 1)
If (strFirstCharacter = ONE_QUOTE And strLastCharacter = ONE_QUOTE) Then
strConvertedFormula = Mid(strFormula, 2, (intStringLength - 2))
strConvertedFormula = Replace(strConvertedFormula, TWO_QUOTES, ONE_QUOTE)
End If
formulaStringToString_End:
formulaStringToString = strConvertedFormula
Exit Function
formulaStringToString_Err:
strConvertedFormula = ""
Debug.Print Err.Description
Resume formulaStringToString_End
End Function
Private Function daysToInches(ByVal inputDays As Integer) As Double
daysToInches = inputDays * inchesPerDay
End Function
Private Function formatInches(ByVal inputInches As Double) As String
formatInches = Format(inputInches, "0.00000") & " in"
End Function
Public Sub saveImages()
Save_GIF
Save_pdf
End Sub
Private Sub Save_GIF()
'Enable diagram services
Dim DiagramServices As Integer
Dim thisFileName As String, thisFilePath As String, thisFileExtension As String
Dim thisDocument As Document
Set thisDocument = ActiveDocument
DiagramServices = thisDocument.DiagramServicesEnabled
thisDocument.DiagramServicesEnabled = visServiceVersion140
thisFilePath = thisDocument.FullName
thisFileName = thisDocument.Name
thisFileExtension = Right(thisFileName, Len(thisFileName) - _
InStrRev(thisFileName, ".", , vbTextCompare))
thisFilePath = Left(thisFilePath, Len(thisFilePath) - Len(thisFileName))
thisFileName = Left(thisFileName, Len(thisFileName) - Len(thisFileExtension) - 1)
Application.Settings.SetRasterExportResolution visRasterUseSourceResolution, 96#, 96#, _
visRasterPixelsPerInch
Application.Settings.SetRasterExportSize visRasterFitToSourceSize, 16.666667, 20.145833, _
visRasterInch
Application.Settings.RasterExportDataFormat = visRasterNonInterlace
Application.Settings.RasterExportColorReduction = visRasterAdaptive
Application.Settings.RasterExportRotation = visRasterNoRotation
Application.Settings.RasterExportFlip = visRasterNoFlip
Application.Settings.RasterExportBackgroundColor = 16777215
Application.Settings.RasterExportTransparencyColor = 16777215
Application.Settings.RasterExportUseTransparencyColor = False
Application.ActiveWindow.Page.Export thisFilePath & thisFileName & ".gif"
'Restore diagram services
ActiveDocument.DiagramServicesEnabled = DiagramServices
End Sub
Private Sub Save_pdf()
'Enable diagram services
Dim DiagramServices As Integer
Dim thisFileName As String, thisFilePath As String, thisFileExtension As String
Dim thisDocument As Document
Set thisDocument = ActiveDocument
DiagramServices = ActiveDocument.DiagramServicesEnabled
ActiveDocument.DiagramServicesEnabled = visServiceVersion140
thisFilePath = thisDocument.FullName
thisFileName = thisDocument.Name
thisFileExtension = Right(thisFileName, Len(thisFileName) - _
InStrRev(thisFileName, ".", , vbTextCompare))
thisFilePath = Left(thisFilePath, Len(thisFilePath) - Len(thisFileName))
thisFileName = Left(thisFileName, Len(thisFileName) - Len(thisFileExtension) - 1)
Application.ActiveDocument.ExportAsFixedFormat visFixedFormatPDF, thisFilePath & _
thisFileName & ".pdf", visDocExIntentPrint, visPrintAll, 1, 1, False, True, True, _
True, False
'Restore diagram services
ActiveDocument.DiagramServicesEnabled = DiagramServices
End Sub
In Visio Objects: ThisDocument(docname)
Dim thisEventHandler As EventHandler
Private Sub Document_DocumentOpened(ByVal Doc As IVDocument)
'Set up handler to catch app-level events
Set thisEventHandler = New EventHandler
Set thisEventHandler.vsoApplication = Application
'Refresh when opened
Module1.setupShapes
End Sub
In Visio Class Modules: EventHandler
Public WithEvents vsoApplication As Visio.Application
'Instantiation of this class contains vsoApplication object which will be set
'to contain a Visio application object. Events from that object can be caught
'and handled here.
Private Sub vsoApplication_CellChanged(ByVal vsoCell As IVCell)
Dim vsoCellname As String
'If values in a timeline object change, re-draw the doc to reflect changed dates
'or physical placement due to timeline object size change.
vsoCellname = vsoCell.Shape.NameU
If InStr(1, LCase(vsoCellname), "timeline", vbTextCompare) > 0 Then Module1.setupShapes
End Sub
Private Sub vsoApplication_DocumentOpened(ByVal Doc As IVDocument)
Dim vsoDataRecordset As Visio.DataRecordset
Dim intDataRecordsetCount As Integer, thisDataRecordsetNumber As Integer
If Doc.Name = ActiveDocument.Name Then
'Refresh the DataRecordset
intDataRecordsetCount = ActiveDocument.DataRecordsets.Count
For thisDataRecordsetNumber = 1 To intDataRecordsetCount
Set vsoDataRecordset = ActiveDocument.DataRecordsets(thisDataRecordsetNumber)
vsoDataRecordset.Refresh
Next thisDataRecordsetNumber
'Update the drawing to show new data
Module1.setupShapes
End If
End Sub
Procedural State MachineThe following VB code illustrates implementation of a state machine using a Case statement. private enum stStates state1_Name state2_Name end enum private enum txinput_signals input_signal1_Name input_signal2_Name input_signal3_Name end enum initialize_all() While Not FileIO.thisTextStream.AtEndOfStream And Not exit_record_loop FileIO.currentRecord = FileIO.thisTextStream.ReadLine select case currentState.name case state1_Name state1_processingForCurrentRecord() state1_assert_output_signalsForCurrentRecord() state1_determine_input_signalsForCurrentRecord() select case input_signals case input_signal1_Name currentState.name = state2_Name case input_signal2_Name exit_record_loop = true end select case state2_Name state2_processingForCurrentRecord() state2_assert_output_signalsForCurrentRecord() state2_determine_input_signalsForCurrentRecord() if input_signal3_Name then currentState = state1_Name end select close_everything() Wend |