First Shapes - Desktop Liberation

Page Content hide

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.

Download complete project

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

' 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

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

' 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

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 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.