304 lines
10 KiB
QBasic
304 lines
10 KiB
QBasic
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
|
|
|