Sorting a collection

Recap

We are pretty close to having a working roadmapper. Most of the recursion topics have been dealt with aside from sorting which we are going to cover in this section. In addition to complete the tool, we need to work out the scale, and implement whole lot more formatting options, which have also been incorporated into this version, although we wont be covering that here since they are not about recursion. 

Sorting a collection

Its pretty straightforward to write a sort. There are 2 components to an effective sorting capability
  • A recursive procedure to manage the journey through the collection, and swap them if the need to be swapped
  • A procedure that can compare two items and decide which one come before the other applying the terms of the sort
This separation keeps the recursive piece simple (and reusable), regardless of how complex the terms of the sort become.

Terms of sort

Our roadmapper allows a number of sort options. 

  • Sort Target Popularity - The most popular target are sorted to the beginning or the end as appropriate. The popularity of a target is the number of children it has.
  • Sort bars by - a field to use to sort the items on.

  • direction of sort of  the chosen key

Recursive sort caller

This will be a method of cShapeContainer

Public Sub sortChildren()
    Dim sc As cShapeContainer
 
    If pChildren.Count > 0 Then
        For Each sc In pChildren
            sc.sortChildren
        Next sc
        SortColl pChildren
    End If

End Sub

You've seen the format before - in this case it's sort my children's children, then sort my children.

Sort a collection

This is the collection sorter. Notice that the test to see whether we actually need to swap two items. (.needSwap) is separated from the mechanics of sorting and swapping. 

Function SortColl(ByRef coll As Collection) As Long
    Dim ita As Long, itb As Long
    Dim va As Variant, vb As Variant, bSwap As Boolean
    Dim x As cShapeContainer, y As cShapeContainer
    
    For ita = 1 To coll.Count - 1
        For itb = ita + 1 To coll.Count
            Set x = coll(ita)
            Set y = coll(itb)
            bSwap = x.needSwap(y)
            If bSwap Then
                Set va = coll(ita)
                Set vb = coll(itb)
                'Swap the items over
                coll.Add va, , itb
                coll.Add vb, , ita
                'Delete the original items
                coll.Remove ita + 1
                coll.Remove itb + 1
            End If
        Next
    Next
    

End Function

Applying the sort terms

In this case we have 2 modules, one for the popularity sort and one for the sort by field value. 

' decide whether swap is needed sort during sort
Public Function needSwap(y As cShapeContainer) As Boolean

    Dim bSwap As Boolean, sorder As String, xlen As Long, ylen As Long
    xlen = treeLength
    ylen = y.treeLength
    
    sorder = Param("options", "sort target popularity", "value")
    If sorder = "ascending popularity" Then
        bSwap = (xlen < ylen) Or (xlen = ylen And needSwapBar(y))
            
    ElseIf sorder = "descending popularity" Then
            bSwap = (xlen > ylen) Or (xlen = ylen And needSwapBar(y))

    ElseIf "sorder" = "no popularity sort" Then
            bSwap = needSwapBar(y)
    Else
        Debug.Assert False
    End If
    
    needSwap = bSwap
End Function
' the criteria for the sort
Public Function needSwapBar(y As cShapeContainer) As Boolean

    Dim bSwap As Boolean, sorder As String

    sorder = Param("options", "sort bar order", "value")
    If sorder <> "none" Then
        Select Case Param("options", "sort bars by", "value")
        Case "original"
             bSwap = (pSerial > y.Serial And sorder = "ascending") Or (pSerial < y.Serial And sorder = "descending")
                
        Case "sequence"
            bSwap = (Sequence > y.Sequence And sorder = "ascending") Or (Sequence < y.Sequence And sorder = "descending")
    
        Case "activate"
            bSwap = (Activate > y.Activate And sorder = "ascending") Or (Activate < y.Activate And sorder = "descending")
        
        Case "deactivate"
            bSwap = (deActivate > y.deActivate And sorder = "ascending") Or (deActivate < y.deActivate And sorder = "descending")
            
        Case "id"
            bSwap = (ID > y.ID And sorder = "ascending") Or (ID < y.ID And sorder = "descending")
            
        Case "duration"
            bSwap = (Duration > y.Duration And sorder = "ascending") Or (Duration < y.Duration And sorder = "descending")
        
        Case "description"
            bSwap = (Text > y.Text And sorder = "ascending") Or (Text < y.Text And sorder = "descending")
        
        Case Else
            Debug.Assert False
        End Select
    End If
    
    needSwapBar = bSwap
End Function

Code

We are done with all the recursive procedures needed to build the roadmapper. Below is all the code, or you can just download version 5 and start using the tool. Note that the version below has been further embellished over and above what we have been working on up to now. 

cShapeContainer code

' cShapeContainer Class
Option Explicit
Option Compare Text
' type of container
Public Enum scTypeS
     sctdata                ' regular - one for each item
     sctframe               ' the container frame - only one
End Enum

Public Enum sChartTypes
    ctShale = xlAreaStacked  ' chart types for auxilary charts assocaited with roadmap
    ctColumnStacked = xlColumnStacked
    ctLine = xlLine
    ctNone = -1              ' no chart required
    ctDefault = ctNone
End Enum

Public Enum ShapeTypes          ' known shapes that can be used in a roadmpa
    stPentagon = msoShapePentagon
    stRectangle = msoShapeRectangle
    stDefault = msoShapeRectangle
    stRoundedRectangle = msoShapeRoundedRectangle
    stChevron = msoShapeChevron
    stNotchedRightArrow = msoShapeNotchedRightArrow
    stRightArrow = msoShapeRightArrow
    stRightArrowCallout = msoShapeRightArrowCallout
    stNone = -1
    stRectangularCallout = msoShapeRectangularCallout
    stRoundedRectangularCallout = msoShapeRoundedRectangularCallout
    stLineCallout2AccentBar = msoShapeLineCallout2AccentBar
    
End Enum

Public Enum sTreats             ' how to treat cost
    stcAnnual
    stcDuration
    stcOneOffStart
    stcOneOffFinish
    stcDefault = stcAnnual
End Enum

Private Enum edgeTick           ' used privately for complex scaling algorithm
    etStart
    etFinish
    etStartString
    etFinishString
    etEstimatedTicks
End Enum
Const cVersion = 2.21
Const nameStub = "_rm_"             ' all shapes have this prefix so they can be easily ideintifed from othre shapes on the same sheet
Const FrameID = "_frame_"
Const maxticks = 24
Private pscType As scTypeS
Private pShape As Shape
Private pShapeCallout As Shape
Private pDataRow As cDataRow
Private pChildren As Collection
Private pRoot As cShapeContainer
Private pParent As cShapeContainer
Private pdSets As cDataSets
Private pWhere As Range
Private pScaleDates As Variant
Private pStartScale As Date
Private pFinishScale As Date
Private pSerial As Long
Private pTraceability As cShapeTraceability
Private pChartContainer As cChartContainer

Public Property Get Plot() As Range
    Set Plot = pRoot.Where
End Property
Public Property Get Where() As Range
    Set Where = pWhere
End Property
Public Property Get dSets() As cDataSets
    Set dSets = pRoot.dsetCollection
End Property
Public Property Get dsetCollection() As cDataSets
    Set dsetCollection = pdSets
End Property
Public Property Get scType() As scTypeS
    scType = pscType
End Property
Public Property Get Shape() As Shape
    Set Shape = pShape
End Property
Public Property Get Root() As cShapeContainer
    Set Root = pRoot
End Property
Public Property Set Shape(p As Shape)
    Set pShape = p
End Property
Public Property Get Children() As Collection
    Set Children = pChildren
End Property
Public Property Get Parent() As cShapeContainer
    Set Parent = pParent
End Property
Public Property Set Parent(p As cShapeContainer)
    Set pParent = p
End Property
Public Property Get ID() As String
    ID = fetchKey("ID")
End Property

' if parent is confirmed use the parents ID, otherwise go to the data. If blank, use the frame as the target
Public Property Get Target() As String
    Dim s As String
    If Valid Then
        s = pParent.ID
    Else
        s = fetchKey("Target")
        If s = vbNullString Then
            s = pRoot.ID
        End If
    End If
    Target = s
End Property

' pick up the text from the data, or provide a default value for the frame
Public Property Get text() As String
    If pDataRow Is Nothing Then
        Debug.Assert pscType = sctframe
        text = paramTitle
    Else
        Debug.Assert pscType = sctdata
        text = pDataRow.toString("Description")
    End If
End Property
' pick up the callout text
Public Property Get calloutText() As String
    If pDataRow Is Nothing Then
        Debug.Assert pscType = sctframe
        calloutText = ""
    Else
        Debug.Assert pscType = sctdata
        calloutText = pDataRow.toString("Callout")
    End If
End Property
Public Property Get Sequence() As Variant
    Sequence = fieldData("sequence")
End Property
Public Property Get Cost() As Variant
    Cost = fieldData("cost")
End Property
Private Property Get Custom() As String
    Custom = CStr(fieldData("custom"))
End Property
Private Property Get fieldData(s As String) As Variant
    If pDataRow Is Nothing Then
        Debug.Assert pscType = sctframe
    Else
        Debug.Assert pscType = sctdata
        fieldData = pDataRow.Value(s)
    End If
End Property
Private Property Get dateGiven(sf As String) As Boolean
    Dim s As String
    s = fieldData(sf)
    dateGiven = (IsDate(s))
End Property
' get activate date - use frame date if not given
Public Property Get Activate() As Date
    Dim d As Date, mind As Date
 
    If pscType = sctframe Then
        d = paramStartDate
        If pStartScale <> 0 Then
            d = pStartScale
        End If
    Else
        mind = pRoot.Activate
        If dateGiven("activate") Then
            d = fieldData("activate")
            If d < mind Then
                d = mind
            End If
        Else
            d = mind
        End If
    End If

    Activate = d
End Property
' get deactivate date - use frame date if not given
Public Property Get deActivate() As Date
    Dim d As Date, maxd As Date

    If pscType = sctframe Then
        d = paramFinishDate
        If pFinishScale <> 0 Then
            d = pFinishScale
        End If
    Else
        maxd = pRoot.deActivate
        If dateGiven("deactivate") Then
            d = fieldData("deactivate")
            If d > maxd Then
                d = maxd
            End If
        Else
            d = maxd
        End If
    End If

    deActivate = d
End Property
'calculates my width relative to root width using start/finish dates
Private Property Get myWidth() As Single
    If pRoot.Shape Is Nothing Then
        myWidth = paramFrameWidth
    Else
        myWidth = pRoot.Shape.Width * Duration / pRoot.Duration
    End If
End Property
Private Sub adjustforNotch()
    Dim x As Single
    x = 0
    With pShape
        If paramStartAtNotch Then
            If .AutoShapeType = msoShapeChevron Or .AutoShapeType = msoShapeNotchedRightArrow Then
                x = .Height / 2 * Tan(DegreestoRadians(47))
                If .Width < x Then x = .Width
                If x > .Left Then x = .Left
                .Left = .Left - x
                .Width = .Width + x
            End If
        End If
    End With
    
End Sub
Private Function DegreestoRadians(Degrees As Double) As Double
    DegreestoRadians = Degrees / 57.29577951308
End Function
'calculates my left start relative to root width using start/finish dates
Private Property Get myLeft() As Single
    If pRoot.Shape Is Nothing Then
        myLeft = paramFrameLeft
    Else
        myLeft = pRoot.Shape.Left + (Activate - pRoot.Activate + 1) / pRoot.Duration * pRoot.Shape.Width
    End If
End Property
Public Property Get Duration() As Single
    Duration = deActivate - Activate + 1
End Property
' doesnt become valid until a parent is confirmed
Public Property Get Valid() As Boolean
    Valid = (Not pParent Is Nothing)
End Property

' goto the data, or use a default value if the frame
Private Function fetchKey(s As String) As String
    If pDataRow Is Nothing Then
        Debug.Assert pscType = sctframe
        fetchKey = FrameID
    Else
        Debug.Assert pscType = sctdata
        fetchKey = makekey(pDataRow.toString(s))
    End If
End Function
Private Property Get fixupCustomCell(sid As String) As cCell
    Dim cc As cCell
    Set cc = paramCustomCell(sid)
    If cc Is Nothing Then
        Set fixupCustomCell = timeBasedRow.Cell(sid)
    Else
        Set fixupCustomCell = cc
    End If
End Property
' this is the gap parameter for the gap for this shape
Private Property Get paramGap() As Single
    paramGap = fixupCustomCell("gap").Value
End Property
Private Property Get paramCalloutHeightAbove() As Single
    paramCalloutHeightAbove = fixupCustomCell("callout % height").Value
End Property

Private Property Get paramCalloutMaxWidth() As Single
    paramCalloutMaxWidth = fixupCustomCell("callout % width").Value
End Property
Private Property Get paramCalloutPosition() As String
    paramCalloutPosition = LCase(fixupCustomCell("callout position").toString)
End Property
Public Property Get chartStyle() As sChartTypes
    
    Select Case LCase(Param("options", "chart style", "value"))
        Case "shale"
            chartStyle = ctShale
        Case "column stacked"
            chartStyle = ctColumnStacked
        Case "line"
            chartStyle = ctLine
        Case Else
            chartStyle = ctDefault
    End Select
        
End Property
Public Property Get chartCostTreatment() As sTreats
    Dim s As String, cc As cCell
    Set cc = fixupCustomCell("chart cost treatment")
    If Not cc Is Nothing Then s = LCase(cc.toString)
        
    Select Case s
        Case "annual"
            chartCostTreatment = stcAnnual
        Case "duration"
            chartCostTreatment = stcDuration
        Case "one off at start"
            chartCostTreatment = stcOneOffStart
        Case "one off at finish"
            chartCostTreatment = stcOneOffFinish
        Case Else
            chartCostTreatment = stcDefault
    End Select
        
End Property

Public Property Get chartProportion() As Single
    
    chartProportion = (Param("options", "chart proportion", "value"))

End Property
' this is the expansion amount parameter for this shape
Private Property Get paramExpansion() As Boolean
    paramExpansion = (makekey(fixupCustomCell("allow expansion").Value) = "yes")
End Property
' this is the parameter for the height of the shape
Private Property Get paramHeight() As Single
    paramHeight = fixupCustomCell("height").Value
End Property
' this is the  parameter for the width of the frame
Private Property Get paramFrameWidth() As Single
    paramFrameWidth = Param("containers", "width", "value")
End Property
' this is the  parameter for the left position of the frame
Private Property Get paramFrameLeft() As Single
    paramFrameLeft = Param("containers", "left", "value")
End Property
' this is the  parameter for the left position of the frame
Private Property Get paramFrameTop() As Single
    paramFrameTop = Param("containers", "top", "value")
End Property
' this is the  parameter for the title
Private Property Get paramTitle() As String
    paramTitle = Param("options", "title", "value")
End Property
Private Property Get paramStartAtNotch() As Boolean
    paramStartAtNotch = (makekey(fixupCustomCell("start at notch").Value) = "yes")
End Property
' this is the  parameter for the left position of the frame
Private Property Get paramStartDate() As Date
    Dim s As String, dr As cDataRow, d As Date, dsmallest As Date
    s = ParamCell("containers", "start date", "value").toString
    If s = "automatic" Then
        With dSets.DataSet("data")
            For Each dr In .Rows
                d = dr.Value("activate")
                If (d < dsmallest And d <> 0) Or dsmallest = 0 Then
                    dsmallest = d
                End If
            Next dr
        End With
        paramStartDate = dsmallest
    Else
        paramStartDate = Param("containers", "start date", "value")
    End If
End Property
Private Property Get paramFinishDate() As Date
    Dim s As String, dr As cDataRow, d As Date, dbiggest As Date
    s = ParamCell("containers", "finish date", "value").toString
    If s = "automatic" Then
        With dSets.DataSet("data")
            For Each dr In .Rows
                d = dr.Value("deactivate")
                If d > dbiggest Then
                    dbiggest = d
                End If
            Next dr
        End With
        paramFinishDate = dbiggest
    Else
        paramFinishDate = Param("containers", "finish date", "value")
    End If
End Property
' this is the  parameter for the shape to use
Private Property Get paramShapeType() As ShapeTypes
    Dim s As String
    Dim cc As cCell
    If pscType = sctframe Then
        paramShapeType = whichShape(Param("containers", "frame", "value"))
    Else
        paramShapeType = whichShape(fixupCustomCell("shape").toString)
    End If
    

End Property
' this is the parameter for what the callout shape is if required
Private Property Get paramShapeCalloutType() As ShapeTypes

    Dim cc As cCell
    paramShapeCalloutType = stNone
    
    If pscType = sctdata Then

        Set cc = fixupCustomCell("callout")
        If Not cc Is Nothing Then paramShapeCalloutType = whichShape(cc.toString)
        
    End If
    
    
End Property
' this is the  parameter for the shape to use
Private Property Get paramShapeTemplate() As Range

    Dim cc As cCell
    If pscType = sctframe Then
        Set paramShapeTemplate = ParamRange("containers", "frame", "format")
    Else
        Set paramShapeTemplate = fixupCustomCell("format").Where

    End If
   
End Property
' this is the  parameter for the shape to use
Private Property Get paramShapeCalloutTemplate() As Range

    Dim cc As cCell
    ' cant be called for a frame
    Debug.Assert pscType = sctdata
    Set paramShapeCalloutTemplate = fixupCustomCell("callout format").Where

End Property

' this one get the custom parameter cell
Private Property Get paramCustomCell(sValue As String, Optional complain As Boolean = True) As cCell
    Dim sCustom As String
    sCustom = fieldData("Custom")
    If sCustom <> vbNullString Then
        Set paramCustomCell = ParamCell("Custom Bars", sCustom, sValue)
        If paramCustomCell Is Nothing And complain Then
            MsgBox ("could not find custom format definition |" & sCustom & "|" & sValue & "| in parameter sheet")
        End If
    End If
End Property
' this one is complicated - work out which of the time based formats to use
Private Property Get timeBasedRow() As cDataRow
    Dim dr As cDataRow, sd As Date, fd As Date, dataSd As Date, datafd As Date
    For Each dr In dSets.DataSet("roadmap colors").Rows
        sd = dr.Value("decommission from")
        fd = dr.Value("decommission to")
        datafd = deActivate
        
        If Not dateGiven("deactivate") And (sd = 0 Or fd = 0) Then
            Set timeBasedRow = dr
            Exit Function
        
        ElseIf datafd >= sd And datafd <= fd Then
            Set timeBasedRow = dr
            Exit Function
        End If
            
    Next dr
    MsgBox ("Could not find time based parameter for deactivate date " & CStr(deActivate) & " ID " & ID)
End Property

' this is general purpose for dealing with yes/no
Private Property Get ParamYesNo(dsn As String, rid As Variant, sid As Variant) As Boolean
    ParamYesNo = (Param(dsn, rid, sid) = "yes")
End Property
' this is general purpose for getting any parameter
Private Property Get Param(dsn As String, rid As Variant, sid As Variant) As Variant
    Param = ParamCell(dsn, rid, sid).Value
End Property
' this is general purpose for getting any parameter
Private Property Get ParamCell(dsn As String, rid As Variant, sid As Variant) As cCell
    With dSets.DataSet(dsn)
        Set ParamCell = .Cell(rid, sid)
    End With
End Property
' this gets the range a value is on
Private Property Get ParamRange(dsn As String, rid As Variant, sid As Variant) As Range
    Set ParamRange = ParamCell(dsn, rid, sid).Where
End Property
' this is the gap after me
Public Property Get MyGapAfterMe() As Single
    MyGapAfterMe = paramGap
End Property
' the gap to leave before i plot my children if i have any
Public Property Get MyGapBeforeChildren() As Single
    If pChildren.Count > 0 Then
        MyGapBeforeChildren = paramGap
    Else
        MyGapBeforeChildren = 0
    End If
End Property
' how much to allow myself to expand
Public Property Get MyExpansion() As Boolean
    MyExpansion = paramExpansion
    If Not paramExpansion Then
        MyExpansion = biggestBranch() > 1
    End If
End Property
Public Property Get MySpace() As Single
    Dim sc As cShapeContainer
    Dim ht As Single
    If pChildren.Count = 0 Then
        
        ht = paramHeight + MyGapAfterMe
    Else

        If MyExpansion Then
            ht = ht + MyGapBeforeChildren
            For Each sc In pChildren
                ht = ht + sc.MySpace
            Next sc
            ht = ht + MyGapAfterMe()
        Else
           ht = paramHeight + MyGapAfterMe()
        End If

    End If
    MySpace = ht
End Property
Public Property Get MyShapeHeight() As Single
    MyShapeHeight = MySpace - MyGapAfterMe
End Property
Public Property Get Serial() As Long
    Serial = pSerial
End Property
Public Property Let Serial(p As Long)
    pSerial = p
End Property
' calculate the longest branch from here.
Public Function biggestBranch() As Long
    Dim sc As cShapeContainer
    Dim ht As Long, t As Long
    ht = pChildren.Count
    For Each sc In pChildren
       t = sc.biggestBranch()
       If t > ht Then
        ht = t
       End If
    Next sc
    biggestBranch = ht
End Function
Public Sub doShapeCallouts()
    Dim sc As cShapeContainer, n As Long, l As Long
    
    ' is there a callout required?
    If paramShapeCalloutType <> stNone Then
        Set pShapeCallout = Plot.Worksheet.Shapes.AddShape(paramShapeCalloutType, _
               1, 1, 1, 1)
                
        shapeTemplate pShapeCallout, paramShapeCalloutTemplate, text
        With pShapeCallout
            .Name = nameStub & pShape.Name
            .Placement = xlFreeFloating
            .TextFrame.MarginBottom = 0
            .TextFrame.MarginTop = 0
            .TextFrame.Characters.text = calloutText
            .Width = pShape.Width * paramCalloutMaxWidth

            ' how many chars fit on a line
            n = Int((.Width - .TextFrame.MarginLeft - .TextFrame.MarginRight) _
                / PointsToPixelsWidth(.TextFrame.Characters.Font.Size))
            ' how many lines are needed
            l = 1 + ((Len(.TextFrame.Characters.text) - 1) / n)
            .Height = l * PointsToPixelsWidth(.TextFrame.Characters.Font.Size) + _
                .TextFrame.MarginTop + .TextFrame.MarginBottom
            .Top = pShape.Top - .Height * paramCalloutHeightAbove
            
            ' position horizontally
            .Left = pShape.Left
                
            Select Case paramCalloutPosition
                Case "beginning"
                    .Left = .Left + cTail
                Case "middle"
                    .Left = .Left + .Width / 2 + cTail
                Case "end"
                    .Left = .Left + .Width + cTail
                Case Else
                    MsgBox "Unknown call out position " & paramCalloutPosition
            End Select

            
        End With
    End If
    ' do all the children
    For Each sc In pChildren
        sc.doShapeCallouts
    Next sc
End Sub
Private Property Get cTail() As Single
    ' provide likely offset to correct for callout tail
    Dim t As Single
    
    With pShapeCallout
        If isCallout(paramShapeCalloutType) Then
            Select Case paramShapeCalloutType
                Case stLineCallout2AccentBar
                    t = 0.5 * .Width
                Case Else
                    t = -0.29 * .Width
                End Select
        Else
            t = 0
        End If

    ' check we are not going to cause a problem
        If t + .Left < 1 Then t = .Left
        If t > .Width Then t = .Width - 1
    End With
    
    cTail = t
End Property
' this is the most complex part - creating the shapes of the correct size and placing them in the right spot
Public Sub makeShape(Optional xTop As Single = -1)
    Dim sc As cShapeContainer, s As Shape, xNextTop As Single, stCall As ShapeTypes
    Dim tshape As ShapeTypes
    ' this would be the default call - place the frame at the place defined in the parameters
    If xTop = -1 Then
        xTop = paramFrameTop
    End If
    
    ' make a shape
    
    ' stNone will be invisible
    tshape = paramShapeType
    If tshape = stNone Then tshape = stDefault
        
        
    Set pShape = Plot.Worksheet.Shapes.AddShape(tshape, paramFrameLeft, xTop, paramFrameWidth, MyShapeHeight)
    ' apply the format asked for in the parameters and add a label
    shapeTemplate pShape, paramShapeTemplate, text
    
    With pShape
        ' we are going to group the shapes later - this is so we can find them
        .Name = nameStub & .Name
        .Placement = xlFreeFloating
        If paramShapeType = stNone Then .Visible = msoFalse

        If pscType = sctframe Then
            ' width and left are the default

        Else
            ' we have to calculate width and start point using dates relative to scale
            .Width = myWidth
            .Left = myLeft
            adjustforNotch
        End If

    End With

    
    ' this is where it gets tricky
    xNextTop = pShape.Top
    If MyExpansion Then
        ' if we are allowing expansion of targets then need to make a gap to accommodate my children
        xNextTop = xNextTop + MyGapBeforeChildren
    End If
    
    For Each sc In pChildren
        ' make a shape for each of my children
        sc.makeShape xNextTop
        ' figure out how much space my child needed and start the next one after it
        xNextTop = xNextTop + sc.MySpace
    Next sc

End Sub
' call to set to initial values
Public Function Create(rt As cShapeContainer, Optional pr As cDataRow = Nothing, _
                        Optional rplot As Range = Nothing, Optional dss As cDataSets = Nothing)
    If pr Is Nothing Then
        pscType = sctframe
    Else
        pscType = sctdata
    End If
    Set pDataRow = pr
    Set pRoot = rt
    Set pWhere = rplot
    Set pdSets = dss
    rt.Serial = rt.Serial + 1
    pSerial = rt.Serial
    Set pChildren = New Collection
End Function
Public Sub makeChart()
    Dim aScale() As Date
    If chartStyle <> ctNone Then
        'ReDim aScale(LBound(pScaleDates(1)) To UBound(pScaleDates(1)), LBound(pScaleDates(2)) To UBound(pScaleDates(2)))
        aScale = pScaleDates
        Set pChartContainer = New cChartContainer
        With pChartContainer
            .Create pRoot
            .makeChart nameStub, aScale
        End With
    End If
End Sub


' call after all data is loaded to make parent.children associations
Public Sub SpringClean()
    Debug.Assert pscType = sctframe
    Associate
    deleteAllShapes Plot, nameStub
End Sub

' check if this ChildExists in current children
Public Function ChildExists(v As Variant) As cShapeContainer
    On Error GoTo handle
    Set ChildExists = pChildren(makekey(v))
    Exit Function
handle:
    Set ChildExists = Nothing
End Function

' standardize way of treating string items as keys to avoid case problems
Private Function makekey(v As Variant) As String
    makekey = LCase(Trim(CStr(v)))
End Function

' Find object by ID
Public Function Find(vId As Variant) As cShapeContainer
    Dim sc As cShapeContainer, scFound As cShapeContainer
    
    Set scFound = ChildExists(vId)
    ' it wasnt in my children .. see if its in my childrens children etc
    If scFound Is Nothing Then
        For Each sc In pChildren
            Set scFound = sc.Find(vId)
            If Not scFound Is Nothing Then
                Exit For
            End If
        Next sc
    End If
    Set Find = scFound
End Function

' one off reassociation of items from the root to be children of their target
' no need for recursion since to start with all are associated with the top level frame
Private Sub Associate()

    Debug.Assert pscType = sctframe
    
    Dim scParent As cShapeContainer, scChild As cShapeContainer, n As Long
    
    For Each scParent In pChildren
        ' who has me as their target?
        For Each scChild In pChildren
            If scChild.Target = scParent.ID Then
                scParent.Children.Add scChild, scChild.ID
                ' confirm the parent as found
                Set scChild.Parent = scParent
            End If
        Next scChild
    Next scParent
    
' now all we need to do is clean up the children of the frame
    n = pChildren.Count
    While n > 0
        Set scChild = pChildren(n)
        If Not scChild.Valid Then
        ' we get here because we didnt find a target yet
            If scChild.Target <> ID Then
            ' and it wasnt the frame.. so
                MsgBox ("Did not find target " & scChild.Target & " for ID " & scChild.ID)
            End If
            ' confirm the frame as the parent
            Set scChild.Parent = Me

        Else
        ' remove from the frames children as already now child of someone else
            pChildren.Remove (n)
        
        End If
        ' belt and braces
        Debug.Assert scChild.Valid
        n = n - 1
    Wend
End Sub
Private Function isCallout(st As ShapeTypes) As Boolean
    Select Case st
        Case stRoundedRectangularCallout, stRectangularCallout, stRightArrowCallout, stLineCallout2AccentBar
            isCallout = True
        Case Else
            isCallout = False
    End Select
End Function
Private Function whichShape(s As String) As ShapeTypes
    
    Select Case LCase(s)
        Case "pentagon"
            whichShape = stPentagon
        Case "rectangle"
            whichShape = stRectangle
        Case "rounded rectangle"
            whichShape = stRoundedRectangle
        Case "chevron"
            whichShape = stChevron
        Case "notched right arrow"
            whichShape = stNotchedRightArrow
        Case "right arrow"
            whichShape = stRightArrow
        Case "right arrow callout"
            whichShape = stRightArrowCallout
        Case "rectangular callout"
            whichShape = stRectangularCallout
        Case "rounded rectangular callout"
            whichShape = stRoundedRectangularCallout
        Case "none"
            whichShape = stNone
        Case "line callout accent bar"
            whichShape = stLineCallout2AccentBar
        Case Else
            whichShape = stDefault
            MsgBox ("Used default - cant find shape " & s)
            
    End Select
End Function
' apply format from a template cell
Private Sub shapeTemplate(s As Shape, ft As Range, tx As String)
    With s.TextFrame.Characters
        .text = tx
        .Font.Color = ft.Font.Color
        .Font.Size = ft.Font.Size
        s.TextFrame.HorizontalAlignment = ft.HorizontalAlignment
        s.TextFrame.VerticalAlignment = ft.VerticalAlignment
        s.Fill.ForeColor.RGB = ft.Interior.Color
    End With
    With s
        .TextFrame.MarginBottom = 0
        .TextFrame.MarginTop = 0
        .TextFrame.MarginLeft = .TextFrame.MarginLeft * 0.5
        .TextFrame.MarginRight = .TextFrame.MarginRight * 0.5
    End With
End Sub
Public Sub debugReport()
    Dim sc As cShapeContainer
    
    If pChildren.Count = 0 Then
        Debug.Print "--Nochildren:" & ID & ":Target:" & Target
    Else
        Debug.Print "Parent:" & ID & ": has " & CStr(pChildren.Count) & " children"

        For Each sc In pChildren
            Debug.Print "--:report on child:" & sc.ID & " of " & ID
            sc.debugReport
        Next sc
    End If

End Sub

Public Function groupContainers() As Shape
    Dim sr As ShapeRange, gs As Shape
    Dim sarg As String
    Set sr = makearangeofShapes(Where, nameStub)
    Set gs = sr.Group
    gs.Name = nameStub & gs.Name
    Set groupContainers = gs
    
End Function
Public Function createScale() As Variant

    Dim tickType As String
    tickType = Param("containers", "ticks", "value")
    If tickType = "automatic" Then
        tickType = AutoScale
    End If
    pScaleDates = createTicks(tickType)

End Function
' this one figures out the most appropriate scale to use - a bit clunky
Private Function AutoScale() As String
    Dim ticks As Single, tickDiff As Single
    Dim idealticks  As Single, sBest As String, s As String
    Debug.Assert pscType = sctframe
    
    idealticks = maxticks * 0.5
    tickDiff = maxticks + 1
    
    s = "weeks"
    ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
    If Abs(idealticks - ticks) < tickDiff Then
        sBest = s
        tickDiff = Abs(idealticks - ticks)
    End If
        
    s = "months"
    ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
    If Abs(idealticks - ticks) < tickDiff Then
        sBest = s
        tickDiff = Abs(idealticks - ticks)
    End If
        
    s = "quarters"
    ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
    If Abs(idealticks - ticks) < tickDiff Then
        sBest = s
        tickDiff = Abs(idealticks - ticks)
    End If
        
    s = "halfyears"
    ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
    If Abs(idealticks - ticks) < tickDiff Then
        sBest = s
        tickDiff = Abs(idealticks - ticks)
    End If
        
    s = "years"
    ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
    If Abs(idealticks - ticks) < tickDiff Then
        sBest = s
        tickDiff = Abs(idealticks - ticks)
    End If
        

    If tickDiff > maxticks Then
        MsgBox "Couldnt find a feasible automatic scale to use for roadmap " & ID
    End If
    
    AutoScale = sBest
End Function
Private Function createTicks(scaleType As String)
    Dim cds As Date, cdf As Date, xcds As Date, xcdf As Date
    Dim w As Single, p As Single, ticks As Long, dheight As Single, ftop As Single, ft As Range
    Dim s As Shape, st As String
    Dim tScaledates(0 To 2, 0 To maxticks * 2) As Date, n As Long
    Dim sc As cShapeContainer
    Set sc = New cShapeContainer

    ' extend scale in each direction to edge of chosen scale
    cds = limitofScale(scaleType, Activate, deActivate, etStart)
    cdf = limitofScale(scaleType, Activate, deActivate, etFinish)
    
    ' patch in new scale
    pStartScale = cds
    pFinishScale = cdf
    
    p = paramFrameLeft
    dheight = paramHeight / 2

    Set ft = ParamRange("containers", "ticks", "format")
    If dheight < 1.6 * ft.Font.Size Then
        dheight = ft.Font.Size * 1.6
    End If
    ftop = paramFrameTop - dheight
    If ftop < 0 Then
        MsgBox ("not enough room for scale - try changing the top parameter")
        ftop = 0
    End If
    ticks = 0
        xcds = cds
        While xcds < cdf
            ticks = ticks + 1
            If ticks > maxticks Then
                MsgBox "no room to show scale " & scaleType & " :choose another scale"
                Exit Function
            End If
            xcdf = limitofScale(scaleType, xcds, xcds, etFinish)
            If xcdf > xcds Then
                w = myWidth * (xcdf - xcds + 1) / (cdf - cds + 1)
                Set s = Plot.Worksheet.Shapes.AddShape(stRectangle, p, ftop, w, dheight)
                s.Name = nameStub & s.Name
                st = limitofScale(scaleType, xcds, xcdf, etFinishString)
                Call shapeTemplate(s, ft, st)
                p = p + s.Width
                tScaledates(0, n) = xcds
                tScaledates(1, n) = xcdf
                n = n + 1
                xcds = xcdf + 1
                    
            Else
                Debug.Assert True
            End If
        Wend
        If n > 0 Then
            ReDim ascaledates(0 To 1, 0 To n - 1) As Date
            For ticks = 0 To n - 1
                ascaledates(0, ticks) = tScaledates(0, ticks)
                ascaledates(1, ticks) = tScaledates(1, ticks)
            Next ticks
            createTicks = ascaledates
        End If
    
End Function
Private Function limitofScale(scaleType As String, sd As Date, fd As Date, edge As edgeTick) As Variant
        Dim dLastDayOfFinishScale As Date, dFirstDayOfStartScale As Variant
        Dim ss As String, sf As String, ticks As Single
        
        
        
        Select Case Trim(LCase(scaleType))
            Case "weeks"
                dFirstDayOfStartScale = sd
                dLastDayOfFinishScale = fd + 7 - (Weekday(fd) Mod 7)
                ss = Format(sd, "dd-mmm-yy")
                sf = Format(fd, "dd-mmm-yy")
                ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 7
            
            Case "months"
                ' 1st day of start month
                dFirstDayOfStartScale = DateSerial(Year(sd), Month(sd), 1)
                ' last of finish month
                dLastDayOfFinishScale = DateSerial(Year(fd), Month(fd) + 1, 1) - 1
                ss = Format(sd, "mmm-yyyy")
                sf = Format(fd, "mmm-yyyy")
                ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 30
            
            Case "quarters"
                dFirstDayOfStartScale = DateSerial(Year(sd), Month(sd) - ((Month(sd) - 1) Mod 3), 1)
                dLastDayOfFinishScale = DateSerial(Year(fd), Month(fd) + 3 - ((Month(fd) - 1) Mod 3), 1) - 1
                ss = "Q" & CStr(1 + Int((Month(sd) - 1) / 3)) & Format(sd, "yyyy")
                sf = "Q" & CStr(1 + Int((Month(fd) - 1) / 3)) & Format(fd, "yyyy")
                ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 90
                 
            Case "halfyears"
                dFirstDayOfStartScale = DateSerial(Year(sd), Month(sd) - ((Month(sd) - 1) Mod 6), 1)
                dLastDayOfFinishScale = DateSerial(Year(fd), Month(fd) + 6 - ((Month(fd) - 1) Mod 6), 1) - 1
                ss = "H" & CStr(1 + Int((Month(sd) - 1) / 6)) & Format(sd, "yyyy")
                sf = "H" & CStr(1 + Int((Month(fd) - 1) / 6)) & Format(fd, "yyyy")
                ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 183
                 
            Case "years"
                dFirstDayOfStartScale = DateSerial(Year(sd), 1, 1)
                dLastDayOfFinishScale = DateSerial(Year(fd) + 1, 1, 1) - 1
                ss = Format(sd, "yyyy")
                sf = Format(fd, "yyyy")
                ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 365
                
            Case Else
                MsgBox "Invalid scale choice  " & scaleType
                Exit Function
                
        End Select
        Select Case edge
            Case etStart
                limitofScale = dFirstDayOfStartScale
            Case etFinish
                limitofScale = dLastDayOfFinishScale
            Case etFinishString
                limitofScale = sf
            Case etStartString
                limitofScale = ss
            Case etEstimatedTicks
                limitofScale = ticks

            Case Else
                Debug.Assert True
        End Select

End Function
' sort a collection
Function SortColl(ByRef coll As Collection) As Long
    Dim ita As Long, itb As Long
    Dim va As Variant, vb As Variant, bSwap As Boolean
    Dim x As cShapeContainer, y As cShapeContainer
    
    For ita = 1 To coll.Count - 1
        For itb = ita + 1 To coll.Count
            Set x = coll(ita)
            Set y = coll(itb)
            bSwap = x.needSwap(y)
            If bSwap Then
                Set va = coll(ita)
                Set vb = coll(itb)
                'Swap the items over
                coll.Add va, , itb
                coll.Add vb, , ita
                'Delete the original items
                coll.Remove ita + 1
                coll.Remove itb + 1
            End If
        Next
    Next
    

End Function
' how many branches in my tree
Public Function treeLength() As Long
    Dim sc As cShapeContainer
    Dim ht As Long
    ht = 1

    For Each sc In pChildren
        ht = ht + sc.treeLength()
    Next sc
    treeLength = ht
End Function

Public Sub Traceability()
    Dim sc As cShapeContainer
    
    Trace
    For Each sc In pChildren
        sc.Trace
    Next sc

End Sub
    
Public Sub Trace()
    ' create traceability for all shapes - this means we can associate shape back to data that created it
    Dim cj As cJobject
    Set cj = New cJobject
    cj.init Nothing, "shapetraceability"
    
    With cj.Add("statistics")
        .Add "created", Now()
        .Add "user", Environ("USERNAME")
        .Add "version", cVersion
    End With
    
    With cj.Add("parameters")
        .Add "location", pdSets.DataSet("options").Where.Worksheet.Name
    End With
    
    With cj.Add("data")
        .Add "id", ID
    End With
    
    pShape.AlternativeText = cj.Serialize
    Set cj = Nothing
End Sub
' decide whether swap is needed sort during sort
Public Function needSwap(y As cShapeContainer) As Boolean

    Dim bSwap As Boolean, sorder As String, xlen As Long, ylen As Long
    xlen = treeLength
    ylen = y.treeLength
    
    sorder = Param("options", "sort target popularity", "value")
    If sorder = "ascending popularity" Then
        bSwap = (xlen < ylen) Or (xlen = ylen And needSwapBar(y))
            
    ElseIf sorder = "descending popularity" Then
            bSwap = (xlen > ylen) Or (xlen = ylen And needSwapBar(y))

    ElseIf sorder = "no popularity sort" Then
            bSwap = needSwapBar(y)
    Else
        Debug.Assert False
    End If
    
    needSwap = bSwap
End Function
' the criteria for the sort
Public Function needSwapBar(y As cShapeContainer) As Boolean

    Dim bSwap As Boolean, sorder As String

    sorder = Param("options", "sort bar order", "value")
    If sorder <> "none" Then
        Select Case Param("options", "sort bars by", "value")
        Case "original"
             bSwap = (pSerial > y.Serial And sorder = "ascending") Or (pSerial < y.Serial And sorder = "descending")
                
        Case "sequence"
            bSwap = (Sequence > y.Sequence And sorder = "ascending") Or (Sequence < y.Sequence And sorder = "descending")
    
        Case "activate"
            bSwap = (Activate > y.Activate And sorder = "ascending") Or (Activate < y.Activate And sorder = "descending")
        
        Case "deactivate"
            bSwap = (deActivate > y.deActivate And sorder = "ascending") Or (deActivate < y.deActivate And sorder = "descending")
            
        Case "id"
            bSwap = (ID > y.ID And sorder = "ascending") Or (ID < y.ID And sorder = "descending")
            
        Case "duration"
            bSwap = (Duration > y.Duration And sorder = "ascending") Or (Duration < y.Duration And sorder = "descending")
        
        Case "description"
            bSwap = (text > y.text And sorder = "ascending") Or (text < y.text And sorder = "descending")
        
        Case Else
            Debug.Assert False
        End Select
    End If
    
    needSwapBar = bSwap
End Function

Public Sub sortChildren()
    Dim sc As cShapeContainer
 
    If pChildren.Count > 0 Then
        For Each sc In pChildren
            sc.sortChildren
        Next sc
        SortColl pChildren
    End If

End Sub
Private Function vMax(a As Variant, b As Variant) As Variant
    If a > b Then
        vMax = a
    Else
        vMax = b
    End If
End Function
Private Function PointsToPixelsWidth(npoints) As Long
   ' idont know how to do this yet so i'll just approximate for now - wordwrap messes things up
    PointsToPixelsWidth = PointsToPixels(npoints) * 0.72
End Function

Private Function PointsToPixels(npoints) As Long
    PointsToPixels = 24 / 18 * npoints
End Function
Private Function PixelsToPoints(npixels) As Long
    PixelsToPoints = 18 / 24 * npixels
End Function
Private Function pixelsToInches(npixels) As Long
    pixelsToInches = 0.25 / 24 * npixels
End Function


Roadmapper code

Option Explicit
Public Sub RoadMapper()
    Dim dSets As cDataSets

    Dim rData As Range, rParam As Range, rplot As Range
    ' where the parameters are
    Set rParam = rangeExists("Parameters").Worksheet.UsedRange
    ' automatically find where the data is
    Set rData = getLikelyColumnRange
    ' get the data and the parameters
    Set dSets = New cDataSets
    With dSets
        .Create
        .init rData, , "data"
        .init rParam, , , True, "roadmap colors"
        .init rParam, , , True, "containers"
        .init rParam, , , True, "options"
        .init rParam, , , True, "custom bars"
    End With

    With dSets.DataSet("data")
        If .Where Is Nothing Then
            MsgBox ("No data to process")
        Else
            ' check we have fields we need
            If .HeadingRow.Validate(True, "Activate", "Deactivate", "ID", "Target", "Description") Then
            ' where to plot
                Set rplot = rangeExists(dSets.DataSet("options").Cell("frameplot", "value").toString)
                If Not rplot Is Nothing Then
                    Call doTheMap(dSets, rplot)
                End If
            End If
        End If
    End With

End Sub
Private Function rangeExists(sw As String, Optional complain = True) As Range
    On Error GoTo handle
    Set rangeExists = Sheets(sw).Cells.Resize(1, 1)
    Exit Function
handle:
    Set rangeExists = Nothing
    If complain Then
        MsgBox ("Sheet " & sw & " doesnt exist")
    End If
End Function
Private Sub doTheMap(ByRef dSets As cDataSets, rplot As Range)

    Dim scRoot As cShapeContainer, sc As cShapeContainer, dr As cDataRow
    
    ' this will be the root - the frame
    Set scRoot = New cShapeContainer
    scRoot.Create scRoot, , rplot, dSets
    
    With dSets.DataSet("data")
    ' create for each datarow
        For Each dr In .Rows
            Set sc = scRoot.Find(dr.toString("ID"))
            If sc Is Nothing Then
                Set sc = New cShapeContainer
                sc.Create scRoot, dr
                scRoot.Children.Add sc, sc.ID
            Else
                MsgBox sc.ID & " is a duplicate - skipping"
            End If
        Next dr
    End With
    
    With scRoot
    ' sort out the parent/child relationships and delete all the existing shapes on this sheet
        .SpringClean
    
    ' make the scale & sort
        .createScale
        .sortChildren
    
    ' plot the shapes, any callouts and create traceability for each shape
        .makeShape
        .doShapeCallouts
        
    ' create a chart if its needed
        .makeChart
    ' group everything
        .groupContainers
    End With

End Sub
For help and more information join our community,  follow the blog,  follow me on twitter, or follow me on g+
Comments