103 lines
3.0 KiB
OpenEdge ABL
103 lines
3.0 KiB
OpenEdge ABL
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
|