### 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.
• 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
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
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
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
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
' 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
'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"

End With

End With

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

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