Concept-Subjects/src/ShapeCreator.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ShapeCreator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private problemIndex_ As Long
Private frontIndex_ As Long

Private data_ As CDS_StaticHierarchy
Private storage_ As API_ShapeStorage
Private destination_ As Visio.Page

Public Function Init(iData As CDS_StaticHierarchy, iDestination As Visio.Page)
  problemIndex_ = 0
  frontIndex_ = 0
  
  Set data_ = iData
  Set destination_ = iDestination
  Set storage_ = New API_ShapeStorage
  Call storage_.Init(0, iDestination.PageSheet.Cells("PageHeight"))
End Function

Public Function CreateAllShapes() As API_ShapeStorage
  Dim iNode As CDS_NodeSH
  For Each iNode In data_.nodes_
    If iNode.rank_ = 1 Then _
      Call CreateRecursive(iNode)
  Next iNode
  Set CreateAllShapes = storage_
End Function

' ========
Private Function CreateRecursive(target As CDS_NodeSH)
  Call CreateItemShape(target)
  Call storage_.Store(target.data_.shape_)
  Call CSE_ProgressBar.IncrementA
  
  If target.children_.Count = 0 Then _
    Exit Function
    
  Dim iChild As CDS_NodeSH
  Dim iChildren As Collection: Set iChildren = OrderChildren(target)
  For Each iChild In iChildren
    Call CreateRecursive(iChild)
  Next iChild
End Function

Private Function CreateItemShape(ByRef target As CDS_NodeSH)
  Dim iShape As Visio.Shape: Set iShape = destination_.Drop(GetMasterFor(target.data_.type_), 0, 0)
  Set target.data_.shape_ = iShape
  iShape.Text = target.data_.text_
  If target.data_.type_ = T_ITEM_PROBLEM Then
    Call AddProblemPrefix(target, iShape)
    iShape.Shapes(2).CellsU("Width") = iShape.Shapes(2).CellsU("Width")
  ElseIf target.data_.type_ = T_ITEM_FRONT Then
    Call AddFrontPrefix(target, iShape)
    iShape.Shapes(2).CellsU("Width") = iShape.Shapes(2).CellsU("Width")
  Else
    Call CellsSetValue(iShape, CELLSU_POSTYPE, target.data_.position_)
    iShape.CellsU("Width") = iShape.CellsU("Width")
  End If
End Function

Private Function AddProblemPrefix(iNode As CDS_NodeSH, ByRef iShape As Visio.Shape)
  problemIndex_ = problemIndex_ + 1
  Dim sPrefix$: sPrefix = Fmt("{1} {2}. ", PROBLEM_PREFIX, problemIndex_)
  iShape.Text = sPrefix & iShape.Text

  Dim cCursor As Visio.Characters: Set cCursor = iShape.Shapes(2).Characters
  cCursor.Begin = 0
  cCursor.End = VBA.Len(sPrefix)
  cCursor.CharProps(visCharacterStyle) = visBold
End Function

Private Function AddFrontPrefix(iNode As CDS_NodeSH, ByRef iShape As Visio.Shape)
  frontIndex_ = frontIndex_ + 1
  Dim sPrefix$: sPrefix = Fmt("{1} {2}. ", FRONT_PREFIX, frontIndex_)
  iShape.Text = sPrefix & iShape.Text

  Dim cCursor As Visio.Characters: Set cCursor = iShape.Shapes(2).Characters
  cCursor.Begin = 0
  cCursor.End = VBA.Len(sPrefix)
  cCursor.CharProps(visCharacterStyle) = visBold
End Function

Private Function OrderChildren(ByRef target As CDS_NodeSH) As Collection
  If target.data_.type_ = T_ITEM_FRONT Then _
    Set target.children_ = OrderByDescendants(target.children_) ' Note: Modifying graph!!
  Set OrderChildren = target.children_
End Function

Private Function OrderByDescendants(iInput As Collection) As Collection
  Dim iDescCounts As New Scripting.Dictionary
  Dim iOut As New Collection
  
  Dim iNode As CDS_NodeSH
  Dim nDescendants&
  Dim nIndex&
  Dim aKey As Variant
  For Each iNode In iInput
    nDescendants = iNode.descendantsCount_
    If iDescCounts.Count = 0 Then
      Call iOut.Add(iNode, CStr(iNode.id_))
      Call iDescCounts.Add(iNode.id_, nDescendants)
    Else
      nIndex = 1
      For Each aKey In iDescCounts
        If iDescCounts(aKey) <= nDescendants Then _
          nIndex = nIndex + 1
      Next aKey
      
      Call iDescCounts.Add(iNode.id_, nDescendants)
      
      If nIndex > iOut.Count Then
        Call iOut.Add(iNode, CStr(iNode.id_))
      Else
        Call iOut.Add(iNode, CStr(iNode.id_), Before:=nIndex)
      End If
    End If
  Next iNode
  
  Set OrderByDescendants = iOut
End Function