Attribute VB_Name = "z_VsoUtilities"
' ====== Extension functions for Visio =====
' Shared module version: 20220624
' Tested in: TestVisio
' Depends on: API_UndoWrapper
' Required reference:
Option Private Module
Option Explicit

Private Const CELLSU_STRUCTURE_TYPE = "User.msvStructureType"
Private Const CELLSU_CONTAINER_RESIZE = "User.msvSDContainerResize"

Private Const RESIZE_FIT_TO_CONTENTS = 2
Private Const SORT_PRECISION = 1# / 25.4  ' mm to inches

Public Function GlobalUndo() As API_UndoWrapper
  Static s_Wrapper As API_UndoWrapper
  
  If s_Wrapper Is Nothing Then
    Set s_Wrapper = New API_UndoWrapper
    Call s_Wrapper.Init(Visio.Application)
  End If
  
  Set GlobalUndo = s_Wrapper
End Function

Public Function FindMaster(iSource As Visio.Document, sMaster$) As Visio.Master
  On Error Resume Next
  Set FindMaster = iSource.Masters.Item(sMaster)
End Function

Public Function SetupFixedGridPage(target As Visio.Page)
  With target.PageSheet
    .CellsU("XRulerOrigin").Formula = "=GUARD(0)"
    .CellsU("YRulerOrigin").Formula = "=GUARD(0)"
    .CellsU("XGridOrigin").Formula = "=GUARD(XRulerOrigin)"
    .CellsU("YGridOrigin").Formula = "=GUARD(YRulerOrigin)"
  End With
End Function

Public Function CellsExists(target As Visio.Shape, sCellName$) As Boolean
  CellsExists = target.CellExistsU(sCellName, visExistsAnywhere)
End Function

Public Function CellsGetValue(target As Visio.Shape, sCellName$) As Variant
  If Not CellsExists(target, sCellName) Then _
    Exit Function
  CellsGetValue = target.CellsU(sCellName)
End Function

Public Function CellsSetValue(target As Visio.Shape, sCellName$, vNewValue As Variant)
   If Not CellsExists(target, sCellName) Then _
    Exit Function
  target.CellsU(sCellName) = vNewValue
End Function

Public Function CellsGetFormula(target As Visio.Shape, sCellName$) As String
  If Not CellsExists(target, sCellName) Then _
    Exit Function
  CellsGetFormula = target.CellsU(sCellName).Formula
End Function

Public Function CellsSetFormula(target As Visio.Shape, sCellName$, sFormula$)
   If Not CellsExists(target, sCellName) Then _
    Exit Function
  target.CellsU(sCellName).Formula = sFormula
End Function

Public Function GetContainingShape(target As Visio.Shape) As Visio.Shape
  Dim vContainer As Variant
  For Each vContainer In target.MemberOfContainers
    Set GetContainingShape = target.ContainingPage.Shapes.ItemFromID(vContainer)
    Exit Function
  Next vContainer
End Function

Public Function VsoShapeExists(sShapeName$, iWhere As Visio.Page) As Boolean
  On Error GoTo RETURN_FALSE
  
  Dim iShape As Visio.Shape: Set iShape = iWhere.Shapes(sShapeName)
  VsoShapeExists = Not iShape Is Nothing
  Exit Function
  
RETURN_FALSE:
  On Error GoTo 0
  VsoShapeExists = False
End Function

Public Function VsoIsListContainer(target As Visio.Shape) As Boolean
  VsoIsListContainer = CellsGetFormula(target, CELLSU_STRUCTURE_TYPE) = """List"""
End Function

Public Function VsoIsMovable(target As Visio.Shape) As Boolean
  If target.OneD Then
    VsoIsMovable = False
  ElseIf CellsExists(target, CELLSU_CONTAINER_RESIZE) Then
    VsoIsMovable = CellsGetValue(target, CELLSU_CONTAINER_RESIZE) = RESIZE_FIT_TO_CONTENTS
  Else
    Dim shpContainer As Visio.Shape: Set shpContainer = GetContainingShape(target)
    If shpContainer Is Nothing Then
      VsoIsMovable = True
    Else
      VsoIsMovable = Not VsoIsMovable(shpContainer)
    End If
  End If
End Function

Public Function VsoIsConnected(iSource As Visio.Shape, iDestination As Visio.Shape) As Boolean
  VsoIsConnected = False
  If iSource.OneD Then _
    Exit Function
  Dim iOuts() As Long: iOuts = iSource.ConnectedShapes(visConnectedShapesOutgoingNodes, "")
  Dim nItem&
  For nItem = LBound(iOuts) To UBound(iOuts) Step 1
    If iOuts(nItem) = iDestination.ID Then
      VsoIsConnected = True
      Exit Function
    End If
  Next nItem
End Function

Public Function VsoApplyColorTo(target As Visio.Shape, nStart&, nEnd&, sColor$)
  Dim iChars As Visio.Characters: Set iChars = target.Characters
  iChars.Begin = nStart
  iChars.End = nEnd
  iChars.CharProps(visCharacterColor) = 1
  
  iChars.End = nStart + 1
  Dim nRow&
  Dim nPrevious&: nPrevious = -1
  Do While iChars.End <= nEnd And iChars.Begin <> iChars.End
    nRow = iChars.CharPropsRow(visBiasLetVisioChoose)
    If nRow <> nPrevious Then
      nPrevious = nRow
      target.CellsSRC(visSectionCharacter, nRow, visCharacterColor).FormulaU = sColor
    End If
    
    iChars.Begin = iChars.End
    iChars.End = iChars.End + 1
  Loop
End Function

' Extracts selected shapes or all shapes on ActivePage if selection is empty
Public Function VsoActiveShapes(iSource As Visio.Application) As Collection
  Dim iSelected As Visio.Selection: Set iSelected = iSource.ActiveWindow.Selection
  Dim iShapes As New Collection
  Dim aShape As Visio.Shape
  If iSelected.Count <> 0 Then
    For Each aShape In iSelected
      Call iShapes.Add(aShape)
    Next aShape
  Else
    For Each aShape In iSource.ActivePage.Shapes
      Call iShapes.Add(aShape)
    Next aShape
  End If
  Set VsoActiveShapes = iShapes
End Function

Public Function VsoGetSelectedShapes(vsoAppl As Visio.Application)
  Dim iShapes As New Collection
  Dim iSelection As Visio.Selection: Set iSelection = vsoAppl.ActiveWindow.Selection
  Dim iShape As Visio.Shape
  For Each iShape In iSelection
    Call iShapes.Add(iShape)
  Next iShape
  Set VsoGetSelectedShapes = iShapes
End Function

Public Function VsoSelectShapes(iShapes As Collection, iPage As Visio.Page)
  ActiveWindow.Page = iPage
  Dim iSelection As Visio.Selection: Set iSelection = ActiveWindow.Selection
  Call iSelection.DeselectAll
  Dim iShape As Visio.Shape
  For Each iShape In iShapes
    Call iSelection.Select(iShape, visSelect)
  Next iShape
  ActiveWindow.Selection = iSelection
End Function

Public Function VsoSelectShapesIDs(iShapeIDs As Collection, iPage As Visio.Page)
  Dim iSelection As Visio.Selection: Set iSelection = iPage.Application.ActiveWindow.Selection
  Call iSelection.DeselectAll
  Dim nShapeID As Variant
  For Each nShapeID In iShapeIDs
    Call iSelection.Select(iPage.Shapes.ItemFromID(CLng(nShapeID)), visSelect)
  Next nShapeID
  iPage.Application.ActiveWindow.Selection = iSelection
End Function

Public Function VsoClearPage(target As Visio.Page)
  Do While target.Shapes.Count > 0
    Call target.Shapes(1).Delete
  Loop
End Function

Public Function VsoShowWholePage(target As Visio.Page)
  target.Application.ActiveWindow.Page = target
  target.Application.ActiveWindow.ViewFit = visFitPage
End Function

Public Function VsoCenterViewOn(target As Visio.Shape)
  Call target.Application.ActiveWindow.ScrollViewTo(target.CellsU("PinX"), target.CellsU("PinY"))
End Function

Public Function VsoIncrementWidth(target As Visio.Shape, valueInMM&)
  If target.OneD Then _
    Exit Function
  If TryIncrementContained(target, valueInMM) Then _
    Exit Function
  
  Dim dWidth As Double: dWidth = target.CellsU("Width")
  If VsoIsListContainer(target) Then
    Dim iMember As Visio.Shape
    Dim memberID As Variant
    For Each memberID In target.ContainerProperties.GetListMembers
      Set iMember = target.ContainingPage.Shapes.ItemFromID(memberID)
      Call iMember.Resize(visResizeDirE, valueInMM, visMillimeters)
    Next memberID
  End If
  If dWidth = target.CellsU("Width") Then _
    Call target.Resize(visResizeDirE, valueInMM, visMillimeters)
End Function

Public Function VsoCalculateFillingFor(target As Visio.Page) As Double
' returns percentage of used space on the page
' does not account for shapes overlapping
  Dim sumAreas As Double: sumAreas = 0
  Dim aShape As Visio.Shape
  For Each aShape In target.Shapes
    If VsoIsMovable(aShape) Then _
      sumAreas = sumAreas + aShape.CellsU("Width") * aShape.CellsU("Height")
  Next aShape
  
  Dim dSheetArea As Double
  dSheetArea = target.PageSheet.CellsU("PageWidth") * target.PageSheet.CellsU("PageHeight")
  
  If dSheetArea <> 0 Then _
    VsoCalculateFillingFor = sumAreas / dSheetArea
End Function

' Sort by topmost and leftmost position of a shape
Public Function VsoGeometricSort(ByRef target() As Long, iPage As Visio.Page)
  If Not IsArrayAllocated(target) Then _
    Exit Function
  Call GeometricQuickSort(iPage, target, LBound(target, 1), UBound(target, 1))
End Function

' ==========
Private Function TryIncrementContained(target As Visio.Shape, valueInMM&) As Boolean
  TryIncrementContained = False
  Dim wrapper As Visio.Shape: Set wrapper = GetContainingShape(target)
  If wrapper Is Nothing Then _
    Exit Function
  If Not VsoIsListContainer(wrapper) Then _
    Exit Function
  
  Call VsoIncrementWidth(wrapper, valueInMM)
  TryIncrementContained = True
End Function

Private Function GeometricQuickSort(iPage As Visio.Page, ByRef target() As Long, ByVal nLow&, ByVal nHigh&)
  Do While nLow < nHigh
    Dim nPivot&: nPivot = GSPartition(iPage, target, nLow, nHigh)
    Call GeometricQuickSort(iPage, target, nLow, nPivot - 1)
    nLow = nPivot + 1
  Loop
End Function

Private Function GSPartition(iPage As Visio.Page, ByRef target() As Long, nLow&, nHigh&) As Long
  Dim iPivot As Visio.Shape: Set iPivot = iPage.Shapes.ItemFromID(target(nHigh))
  Dim nSmallest&: nSmallest = nLow - 1
  Dim iTempValue As Variant
  
  Dim n&
  For n = nLow To nHigh - 1
    Dim iShape As Visio.Shape: Set iShape = iPage.Shapes.ItemFromID(target(n))
    If GeometricCompare(iShape, iPivot) < 0 Then
      nSmallest = nSmallest + 1
      iTempValue = target(nSmallest)
      target(nSmallest) = target(n)
      target(n) = iTempValue
    End If
  Next n
  
  nSmallest = nSmallest + 1
  iTempValue = target(nSmallest)
  target(nSmallest) = target(nHigh)
  target(nHigh) = iTempValue
  
  GSPartition = nSmallest
End Function

Private Function GeometricCompare(iShape1 As Visio.Shape, iShape2 As Visio.Shape) As Double
  GeometricCompare = iShape2.CellsU("PinY") + iShape2.CellsU("Height") / 2# - iShape1.CellsU("PinY") - iShape1.CellsU("Height") / 2#
  If Abs(GeometricCompare) > SORT_PRECISION Then _
    Exit Function
  GeometricCompare = iShape1.CellsU("PinX") - iShape1.CellsU("Width") / 2# - iShape2.CellsU("PinX") + iShape2.CellsU("Width") / 2#
  If Abs(GeometricCompare) > SORT_PRECISION Then _
    Exit Function
  GeometricCompare = 0
End Function