VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_ShapeStorage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ===== Visio shape storage manager simulating grid ========
' Shared module version: 20210707
' Depends on:
' Required reference: Scripting
Option Explicit

Private Const SS_AREA_RATIO = 20#      ' target sum widht / height ratio
Private Const SS_STORAGE_GAP = 0.1    ' gap between shapes in inches
Private Const SS_STORAGE_MAX_LVL = 1024 ' maximum number of rows

Private Const SS_PRECISION = 3

Private originX_ As Double
Private originY_ As Double

Private areaHeight_ As Double

Private lvlCount_ As Long

Private levelHeight_(1 To SS_STORAGE_MAX_LVL) As Double
Private levelX_(1 To SS_STORAGE_MAX_LVL) As Double
Private levelY_(1 To SS_STORAGE_MAX_LVL) As Double

Public items_ As Scripting.Dictionary

Public Function Init(xOrigin As Double, yOrigin As Double)
  originX_ = xOrigin
  originY_ = yOrigin
  areaHeight_ = 0
  lvlCount_ = 0
  
  Set items_ = New Scripting.Dictionary
End Function

Public Property Get TargetPage() As Visio.Page
  If items_.Count > 0 Then _
    Set TargetPage = items_.Items(1).Parent
End Property

Public Function Store(target As Visio.Shape) As Boolean
  Store = Not items_.Exists(target.ID)
  If Not Store Then _
    Exit Function
  
  Call items_.Add(target.ID, target)
  
  Dim nLvl&: nLvl = GetLevelForNew(target.Cells("Height"))
  target.Cells("PinX") = levelX_(nLvl) + target.Cells("Width") / 2#
  target.Cells("PinY") = levelY_(nLvl) + target.Cells("Height") / 2#
  
   Call IncrementLevelWidth(nLvl, target.Cells("Width"))
End Function

Public Function GiveBack(target As Visio.Shape)
  If items_.Exists(target.ID) Then _
    Call items_.Remove(target.ID)
End Function

'=============
Private Function GetLevelForNew(dHeight As Double) As Long
  Dim minLvl&: minLvl = 0
  Dim minX As Double: minX = 100000000#
  Dim nLvl&
  For nLvl = 1 To lvlCount_ Step 1
    If VBA.Round(levelHeight_(nLvl), SS_PRECISION) + SS_STORAGE_GAP >= VBA.Round(dHeight, SS_PRECISION) And _
        VBA.Round(minX, SS_PRECISION) > VBA.Round(levelX_(nLvl), SS_PRECISION) Then
      minLvl = nLvl
      minX = levelX_(nLvl)
    End If
  Next nLvl
  
  If minLvl = 0 Then
    GetLevelForNew = CreateNewLevel(dHeight)
  ElseIf levelX_(minLvl) > SS_AREA_RATIO * VBA.Round(areaHeight_, SS_PRECISION) And lvlCount_ <= SS_STORAGE_MAX_LVL Then
    GetLevelForNew = CreateNewLevel(dHeight)
  Else
    GetLevelForNew = minLvl
  End If
End Function

Private Function CreateNewLevel(dHeight As Double) As Long
  lvlCount_ = lvlCount_ + 1
  levelHeight_(lvlCount_) = dHeight
  levelY_(lvlCount_) = originY_ + areaHeight_
  levelX_(lvlCount_) = originX_
  areaHeight_ = areaHeight_ + dHeight + SS_STORAGE_GAP
  
  CreateNewLevel = lvlCount_
End Function

Private Function IncrementLevelWidth(nLvl&, incWidth As Double)
  levelX_(nLvl) = levelX_(nLvl) + SS_STORAGE_GAP + incWidth
End Function