Recap
We’ve read our data, and set up the parameters. The data structures are working according to our debug reports, and we have dipped our toe into recursion. Now to pull it all together and create some shapes. Since we have parent/child relationships, the idea here is that the parent shape will be big enough to accommodate all its children, grandchildren and so on. This is where recursion will be needed, to predict the height a shape is going to be.
What does it look like
Well- not too good. But notice that all the shapes including the frame are the right height. The starting points and widths we still need to work on – but that will be the subject of the next section. Lets look at how recursion has helped to calculate the heights of each shape, and the processing order ‘ me, then my children’ has ensured that the zOrder (what goes on top), is correct.
There it is. Needs a bit of work, but most of the tricky stuff is done. Lets start by looking at the height recursion
Calculating the height of each shape
To make this simpler, i have defined some properties that are calculated for each shape, using parameters taken from the parameter sheet as a base. These are combined using options from the parameter sheet to decide the height of any given shape.
The code for these properties is as follows – the properties paramXXXX that are referenced are taken from the parameter sheet, the full code will be at the end of this section as usual. The interesting ones from a recursion perspective are
- myExpansion – calls the recursive function biggestBranch(), whose purpose is to work down the layers of children from here to see the largest number of children any of my chidren have. The reason is that we have provided an option to suppress expansion of a parent if there is only one child. But this can only apply if none of the children have more than one child.
- mySpace- calls itself until the chain of children is completed. This is because mySpace for any item is in fact the space needed for all its children and all its childrens’ children and so on. Since the frame is treated as shape, the same way as all the others, mySpace for the frame is calculated to be the space needed for all the shapes, their children and so on.
This is a tricky concept, so read the code over and make sure you get it.
' 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
Making the shapes
Once we have the ability to figure out the height of any given shape, all thats left now (aside from scaling and formatting) is deciding where to plot them. Again we have to do this recursively because we have to plot all our children, childrens’ children etc, before we can move on to the next shape and know where to start plotting it.
Here is the code below. Notice that we create our own shape of myShapeHeight – which itself calls the recursive mySpace to figure out the space needed for the parent, then we call our selves for each of the children.
' 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 ' 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 Set pShape = Plot.Worksheet.Shapes.AddShape(paramShapeType, 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 If pscType = sctframe Then ' width and left are all ok Else ' we have to calculate width and start point using dates relative to scale ' we'll replace these 100 when we figure out how .Width = 100 .Left = 100 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
Next steps
The next recursion topic will be sorting. Sorting is a classic instance of recursion. Our roadmapper is going to need the capability to sort the items in various ways to allow the most effective presentation. In the next section, we will cover how to sort a collection, using recursion.
Complete code so far – version 4
The code is getting rather large now. You can replace the Roadmapper module and the cShapeContainer class with the code below, or go to the downloadable items page and pick up version 4.
RoadMapper Module
Option Explicit
Public Sub RoadMapper()
Dim dSets As cDataSets
Dim rData As Range, rParam As Range, rplot As Range
Set rData = Range("InputData!$a$1:$e$1")
Set rParam = Range("Parameters!$a:$g")
Set rplot = Range("inputdata!a1")
' 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"
End With
'--check reading parameters worked----------------------------------------
Debug.Print dSets.DataSet("options").Value("chart style", "value")
Debug.Print dSets.DataSet("roadmap colors").Value("current", "shape")
Debug.Print dSets.DataSet("containers").Value("frame", "comments")
'-----------------------------------------------------------------
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
Call doTheMap(dSets, rplot)
End If
End If
End With
End Sub
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
' sort out the parent/child relationships and delete all the existing shapes on this sheet
scRoot.SpringClean
' plot the shapes and group them
scRoot.makeShape
scRoot.groupContainers
'debug to see what that all looks like
scRoot.debugReport
End Sub
cShapeContainer Class
' cShapeContainer Class
Option Explicit
Option Compare Text
Public Enum scTypeS
sctData
sctframe
End Enum
Public Enum ShapeTypes
stPentagon = msoShapePentagon
stRectangle = msoShapeRectangle
stDefault = msoShapeRectangle
stRoundedRectangle = msoShapeRoundedRectangle
stChevron = msoShapeChevron
stNotchedRightArrow = msoShapeNotchedRightArrow
stRightArrow = msoShapeRightArrow
stRightArrowCallout = msoShapeRightArrowCallout
End Enum
Const nameStub = "_rm_"
Const FrameID = "_frame_"
Private pscType As scTypeS
Private pShape 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
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 = "Roadmap Frame"
Else
Debug.Assert pscType = sctData
Text = pDataRow.toString("Description")
End If
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
' this is the gap parameter for the gap for this shape
Private Property Get paramGap() As Single
paramGap = Param("containers", "gap", "value")
End Property
' this is the expansion amount parameter for this shape
Private Property Get paramExpansion() As Boolean
paramExpansion = ParamYesNo("containers", "allow expansion", "value")
End Property
' this is the parameter for the height of the shape
Private Property Get paramHeight() As Single
paramHeight = Param("containers", "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 shape to use
Private Property Get paramShapeType() As ShapeTypes
Dim s As String
s = Param("roadmap colors", "current", "shape")
paramShapeType = whichShape(s)
End Property
' this is the parameter for the shape to use
Private Property Get paramShapeTemplate() As Range
Set paramShapeTemplate = ParamRange("roadmap colors", "current", "format")
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
' 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
' 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
' 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
Set pShape = Plot.Worksheet.Shapes.AddShape(paramShapeType, 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
If pscType = sctframe Then
' width and left are all ok
Else
' we have to calculate width and start point using dates relative to scale
' we'll replace these 100 when we figure out how
.Width = 100
.Left = 100
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
Set pChildren = New Collection
End Function
' 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 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 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
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
Dim sarg As String
Set sr = makearangeofShapes(Where, nameStub)
Set groupContainers = sr.Group
End Function
For help and more information join our community, follow the blog or follow me on Twitter.