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. This design only allows one Timeline object in a drawing. 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 References Visual Basic for Applications Microsoft Visio 14.0 Type Library OLE Automation Microsoft Office 14.0 Object Library ---------------------------------------- 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, cellUniqueIDValue As String, cellDateLine 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, dateTest As Date Dim dimLeft As Double, dimRight As Double, dimTotal As Double, dimLeftLocal As Double, 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 Dim isDateLine As Boolean '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" cellDateLine = "Prop._VisDM_DateLine" 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 cellUniqueIDValue = formulaStringToString(thisShape.Cells(cellUniqueID).Formula) If cellUniqueIDValue <> "" 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) Or thisShape.CellExists(cellDateLine, True) Then dateFinishLocal = dateStartLocal isDateLine = False If thisShape.CellExists(cellDateLine, True) Then isDateLine = True End If '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.125 in" 'Cells are set as strings, so they have to be formatted properly. If isDateLine Then isDateLine = True thisShape.Cells("BeginX").Formula = stringToFormulaForString(setLeft) thisShape.Cells("EndX").Formula = stringToFormulaForString(setLeft) thisShape.Cells("PinX").Formula = stringToFormulaForString(setLeft) Else 'If object is a DateLine then don't re-dimension it thisShape.Cells("PinX").Formula = stringToFormulaForString(setLeft) thisShape.Cells("Height").Formula = stringToFormulaForString(setHeight) thisShape.Cells("Width").Formula = stringToFormulaForString(setWidth) End If '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 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, 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 Save_PNG 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 Private Sub Save_PNG() '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 + visServiceVersion150 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 visRasterUseScreenResolution, 144#, 144#, visRasterPixelsPerInch Application.Settings.SetRasterExportSize visRasterFitToSourceSize, 16.027778, 10.541667, visRasterInch Application.Settings.RasterExportDataFormat = visRasterInterlace Application.Settings.RasterExportColorFormat = visRaster24Bit 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 & ".png" 'Restore diagram services ActiveDocument.DiagramServicesEnabled = DiagramServices End Sub Public Sub setupDateLine() 'Copyright (c) 2017 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice. Dim DiagramServices As Integer Dim UndoScopeID1 As Long Dim vsoShape1 As Visio.Shape Dim intPropRow2 As Integer Dim vsoSelection As Visio.Selection 'Enable diagram services DiagramServices = ActiveDocument.DiagramServicesEnabled ActiveDocument.DiagramServicesEnabled = visServiceVersion140 + visServiceVersion150 UndoScopeID1 = Application.BeginUndoScope("Define Shape Data") Set vsoSelection = ActiveWindow.Selection Set vsoShape1 = ctype(vsoSelection, vsoshape) intPropRow2 = vsoShape1.AddRow(visSectionProp, visRowLast, visTagDefault) vsoShape1.Section(visSectionProp).Row(intPropRow2).NameU = "_VisDM_DateLine" vsoShape1.CellsSRC(visSectionProp, intPropRow2, visCustPropsLabel).FormulaU = """DateLine""" vsoShape1.CellsSRC(visSectionProp, intPropRow2, visCustPropsType).FormulaU = "0" vsoShape1.CellsSRC(visSectionProp, intPropRow2, visCustPropsFormat).FormulaU = "" vsoShape1.CellsSRC(visSectionProp, intPropRow2, visCustPropsLangID).FormulaU = "1033" vsoShape1.CellsSRC(visSectionProp, intPropRow2, visCustPropsCalendar).FormulaU = "" vsoShape1.CellsSRC(visSectionProp, intPropRow2, visCustPropsPrompt).FormulaU = "" vsoShape1.CellsSRC(visSectionProp, intPropRow2, visCustPropsValue).FormulaU = """DateLine""" vsoShape1.CellsSRC(visSectionProp, intPropRow2, visCustPropsSortKey).FormulaU = "" Application.EndUndoScope UndoScopeID1, True 'Restore diagram services ActiveDocument.DiagramServicesEnabled = DiagramServices End Sub ---------------------------------------------------------------------------------------------------- In Visio Objects > ThisDocument (docname) ---------------------------------------- Dim thisEventHandler As EventHandler Private Sub Document_BeforeDocumentSave(ByVal doc As IVDocument) Module1.setupShapes End Sub 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 Class Modules > EventHandler ---------------------------------------- Option Explicit 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