VBCommons/visio/z_CCVsoExtension.bas

Attribute VB_Name = "z_CCVsoExtension"
' ============== Module for additional functionality for CIHT CONCEPT ====================
' Shared module version: 20220714
' Tested in: TestVisio
' Depends on: CDS_Factorizator, z_VsoUtilities, CDS_Graph, API_VsoWrapper, z_VsoGraph
' Required reference: Scripting
Option Explicit

Private Const CC_DEFAULT_CONNECTOR_NAME = "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"

Public Sub CC_DispatchCommand(sCommand$)
  Select Case sCommand
    Case "WidthAdd10":        Call CC_WidthAdd10
    Case "WidthSub10":        Call CC_WidthSub10
    Case "TopAlignment":      Call CC_TopAlignment
    Case "LeftAlignment":     Call CC_LeftAlignment
    Case "ExpandStraight":    Call CC_ExpandStraight
    Case "ExpandReverse":     Call CC_ExpandReverse
    Case "GotoLinkBegin":     Call CC_GotoLinkBegin
    Case "GotoLinkEnd":       Call CC_GotoLinkEnd
    Case "IterateSimilar":    Call CC_IterateSimilar
    Case "RedirectConnects":  Call CC_RedirectConnectors
    Case "CreateConnects":    Call CC_CreateConnectors
    Case "Convert1251":       Call CC_Convert1251
  End Select
End Sub

Public Sub CC_SelectByID()
  Dim target As Visio.Shape
  Dim sName$: sName = VBA.InputBox("Input ID")
  If sName = vbNullString Then _
    Exit Sub
  
  If Not IsNumeric(sName) Then
    Call MsgBox("Invalid ID", vbExclamation)
    Exit Sub
  End If
  
  On Error Resume Next
  Set target = Visio.Application.ActivePage.Shapes.ItemFromID(CLng(sName))
  On Error GoTo 0
  
  If target Is Nothing Then
    Call MsgBox("Invalid ID", vbExclamation)
    Exit Sub
  End If
  
  Dim iSelection As Visio.Selection: Set iSelection = Visio.Application.ActiveWindow.Selection
  Call iSelection.DeselectAll
  Call iSelection.Select(target, visSelect)
  Visio.Application.ActiveWindow.Selection = iSelection
  Call Visio.Application.ActiveWindow.CenterViewOnShape(target, visCenterViewSelectShape)
End Sub

Public Sub CC_GotoLinkBegin()
  Dim iConnector As Visio.Shape: Set iConnector = GetSelectedConnector
  If iConnector Is Nothing Then _
    Exit Sub
  Dim iTarget As Visio.Shape: Set iTarget = VsoGetConnectedShape(iConnector, bBegin:=True)
  Call VsoCenterViewOn(iTarget)
End Sub

Public Sub CC_GotoLinkEnd()
  Dim iConnector As Visio.Shape: Set iConnector = GetSelectedConnector
  If iConnector Is Nothing Then _
    Exit Sub
  Dim iTarget As Visio.Shape: Set iTarget = VsoGetConnectedShape(iConnector, bBegin:=False)
  Call VsoCenterViewOn(iTarget)
End Sub

Public Sub CC_WidthAdd10()
  If ActiveWindow.Selection.Count = 0 Then
    Call MsgBox("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>", vbExclamation)
    Exit Sub
  End If
  Call GlobalUndo.BeginScope("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>")
  ThisDocument.DiagramServicesEnabled = visServiceStructureBasic
  
  Call VsoIncrementWidth(ActiveWindow.Selection(1), 10)
  
  ThisDocument.DiagramServicesEnabled = 0
  Call GlobalUndo.EndScope
End Sub

Public Sub CC_WidthSub10()
  If ActiveWindow.Selection.Count = 0 Then
    Call MsgBox("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>", vbExclamation)
    Exit Sub
  End If
  Call GlobalUndo.BeginScope("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>")
  ThisDocument.DiagramServicesEnabled = visServiceStructureBasic
  
  Call VsoIncrementWidth(ActiveWindow.Selection(1), -10)
  
  ThisDocument.DiagramServicesEnabled = 0
  Call GlobalUndo.EndScope
End Sub

Public Sub CC_IterateSimilar()
Attribute CC_IterateSimilar.VB_ProcData.VB_Invoke_Func = "F"
  Dim iSelected As Visio.Selection: Set iSelected = Visio.Application.ActiveWindow.Selection
  Dim iShape As Visio.Shape
  Dim nItem&: nItem = 1
  Do
    If nItem > iSelected.Count Then _
      Exit Do
    Set iShape = iSelected.Item(nItem)
    If iShape.OneD Then
      Call iSelected.Select(iShape, visDeselect)
    Else
      nItem = nItem + 1
    End If
  Loop
  
  If iSelected.Count = 0 Then
    Call MsgBox("Select at least one shape", vbExclamation)
    Exit Sub
  End If
  
  Dim iTarget As Visio.Shape: Set iTarget = iSelected.Item(1)
  
  Dim idList As Scripting.Dictionary: Set idList = ExtractShapeIDs(iTarget)
  If idList Is Nothing Then
    Call MsgBox("Selected shape is missing IDs", vbExclamation)
    Exit Sub
  End If
  
  Dim filteredIDs As Collection: Set filteredIDs = FilterPageIDs(Visio.Application.ActivePage, idList)
  
  Call iSelected.DeselectAll
  Dim nStart&: nStart = -1
  For nItem = 1 To filteredIDs.Count Step 1
    Set iShape = filteredIDs.Item(nItem)
    If nStart <> -1 Then _
      Call iSelected.Select(iShape, visSelect)
    If iShape.ID = iTarget.ID Then
      nStart = nItem
      If nStart = filteredIDs.Count Then _
        nStart = 1
    End If
  Next nItem
  
  For nItem = 1 To nStart Step 1
    Call iSelected.Select(filteredIDs.Item(nItem), visSelect)
  Next nItem
  
  Visio.Application.ActiveWindow.Selection = iSelected
  Call Visio.Application.ActiveWindow.CenterViewOnShape(iSelected.Item(1), visCenterViewSelectShape)
End Sub

' Create connections from all selected to last selected
Public Sub CC_CreateConnectors()
  Dim iSelected As Visio.Selection: Set iSelected = ThisDocument.Application.ActiveWindow.Selection
  If iSelected.Count < 2 Then
    Call MsgBox("Select at least two shapes", vbExclamation)
    Exit Sub
  End If
  
  Call GlobalUndo.BeginScope("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>")
  
  Dim shapeTo As Visio.Shape: Set shapeTo = iSelected(iSelected.Count)
  Dim shapeFrom As Visio.Shape
  Dim conShp As Visio.Shape
  Dim iMaster As Visio.Master: Set iMaster = FindMaster(ThisDocument, CC_DEFAULT_CONNECTOR_NAME)
  Dim nItem&
  For nItem = 1 To iSelected.Count - 1 Step 1
    Set shapeFrom = iSelected(nItem)
    If shapeFrom.Connects.Count <> 0 Then _
      GoTo NEXT_ITEM
    If iMaster Is Nothing Then
      Call shapeFrom.AutoConnect(shapeTo, visAutoConnectDirNone)
    Else
      Call shapeFrom.AutoConnect(shapeTo, visAutoConnectDirNone, iMaster)
    End If
NEXT_ITEM:
  Next nItem
  
  Call GlobalUndo.EndScope
End Sub

' Move connectors end to last selected
Public Sub CC_RedirectConnectors()
  Dim iSelected As Visio.Selection: Set iSelected = ThisDocument.Application.ActiveWindow.Selection
  If iSelected.Count < 2 Then
    Call MsgBox("Select at least one connector and one shape", vbExclamation)
    Exit Sub
  End If
  
  Dim shapeTo As Visio.Shape: Set shapeTo = iSelected(iSelected.Count)
  If shapeTo.Connects.Count <> 0 Then
    Call MsgBox("Select valid shape last (not connector!)", vbExclamation)
    Exit Sub
  End If
  
  Call GlobalUndo.BeginScope("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>")
  
  Dim nItem&
  For nItem = 1 To iSelected.Count - 1 Step 1
    Call iSelected(nItem).CellsU("EndX").GlueTo(shapeTo.CellsU("PinX"))
  Next nItem
  
  Call GlobalUndo.EndScope
End Sub

Public Sub CC_TopAlignment()
  Dim dGap As Double: dGap = PromptAlignGap
  If dGap = 0 Then _
    Exit Sub
  Dim iShapes As Collection: Set iShapes = VsoActiveShapes(ThisDocument.Application)
  If iShapes.Count = 0 Then _
    Exit Sub

  Dim vsoUI As New API_VsoWrapper: Call vsoUI.SetDocument(ThisDocument)
  Call vsoUI.PauseUI
  ThisDocument.DiagramServicesEnabled = visServiceStructureBasic
  Call GlobalUndo.BeginScope("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>")
  
  Call VsoAlignShapes(iShapes, dGap, bAlignTop:=True)
  
  Call GlobalUndo.EndScope
  ThisDocument.DiagramServicesEnabled = 0
  Call vsoUI.ResumeUI
End Sub

Public Sub CC_LeftAlignment()
  Dim dGap As Double: dGap = PromptAlignGap
  If dGap = 0 Then _
    Exit Sub
  Dim iShapes As Collection: Set iShapes = VsoActiveShapes(ThisDocument.Application)
  If iShapes.Count = 0 Then _
    Exit Sub

  Dim vsoUI As New API_VsoWrapper: Call vsoUI.SetDocument(ThisDocument)
  Call vsoUI.PauseUI
  ThisDocument.DiagramServicesEnabled = visServiceStructureBasic
  Call GlobalUndo.BeginScope("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>")
  
  Call VsoAlignShapes(iShapes, dGap, bAlignTop:=False)
  
  Call GlobalUndo.EndScope
  ThisDocument.DiagramServicesEnabled = 0
  Call vsoUI.ResumeUI
End Sub

Public Sub CC_ExpandReverse()
  If ThisDocument.Application.ActiveWindow.Selection.Count = 0 Then
    Call MsgBox("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>", vbExclamation)
    Exit Sub
  End If
  
  Dim iSelected As Collection: Set iSelected = VsoActiveShapes(ThisDocument.Application)
  Dim iGraph As CDS_Graph: Set iGraph = ScanGraph(iSelected, bReverseLinks:=True)
  Call VsoSelectShapesIDs(iGraph.Nodes, ThisDocument.Application.ActivePage)
End Sub

Public Sub CC_ExpandStraight()
  If ThisDocument.Application.ActiveWindow.Selection.Count = 0 Then
    Call MsgBox("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>", vbExclamation)
    Exit Sub
  End If
  
  Dim iSelected As Collection: Set iSelected = VsoActiveShapes(ThisDocument.Application)
  Dim iGraph As CDS_Graph: Set iGraph = ScanGraph(iSelected, bReverseLinks:=False)
  Call VsoSelectShapesIDs(iGraph.Nodes, ThisDocument.Application.ActivePage)
End Sub

Public Sub CC_Convert1251()
  Dim iShapes As Collection: Set iShapes = VsoActiveShapes(ThisDocument.Application)
  If iShapes.Count = 0 Then _
    Exit Sub
    
  Dim aShape As Visio.Shape
  For Each aShape In iShapes
    Dim sText$: sText = aShape.Text
    Dim sNewText$: sNewText = Convert1251(aShape.Text)
    If sText <> sNewText Then _
      aShape.Text = sNewText
  Next aShape
End Sub

Public Function VsoAlignShapes(target As Collection, dGap As Double, bAlignTop As Boolean)
  Dim iFactors As New CDS_Factorizator
  Call iFactors.Init(Application.ConvertResult(dGap, "mm", "in"))
  
  Dim sCellPosition$: sCellPosition = IIf(bAlignTop, "PinY", "PinX")
  Dim sDimension$: sDimension = IIf(bAlignTop, "Height", "Width")
  Dim k&: k = IIf(bAlignTop, 1, -1)
  
  Dim aShape As Visio.Shape
  For Each aShape In target
    If VsoIsMovable(aShape) Then _
      Call iFactors.Insert(aShape.ID, k * (aShape.CellsU(sCellPosition) + k * aShape.CellsU(sDimension) / 2#))
  Next aShape
  
  For Each aShape In target
    Dim vFactor As Variant: vFactor = iFactors.FactorFor(aShape.ID)
    If vFactor = Empty Then _
      GoTo NEXT_SHAPE
    If vFactor = aShape.ID Then _
      GoTo NEXT_SHAPE
      
    Dim targetPos As Double: targetPos = iFactors.FactorValueFor(vFactor)
    aShape.CellsU(sCellPosition) = k * (targetPos - aShape.CellsU(sDimension) / 2#)
NEXT_SHAPE:
  Next aShape
End Function

Public Function ExtractShapeIDs(target As Visio.Shape) As Scripting.Dictionary
  Dim sText$: sText = target.Text
  If sText = vbNullString And target.Shapes.Count > 1 Then _
    sText = target.Shapes(1).Text
  If sText = vbNullString Then _
    Exit Function
  
  Dim sPrefix$: sPrefix = ExtractShapePrefix(sText)
  If sPrefix = vbNullString Then
    Set ExtractShapeIDs = New Scripting.Dictionary
    Call ExtractShapeIDs.Add(VBA.Trim(sText), VBA.Trim(sText))
    Exit Function
  End If
  
  Set ExtractShapeIDs = SplitPrefix(sPrefix)
End Function

Public Function FilterPageIDs(iPage As Visio.Page, iFilter As Scripting.Dictionary) As Collection
  Dim iResult As New Collection
  Dim idList As Scripting.Dictionary
  Dim iShape As Visio.Shape
  For Each iShape In iPage.Shapes
    Set idList = ExtractShapeIDs(iShape)
    If Not idList Is Nothing Then
      Dim iKey As Variant
      For Each iKey In idList.Keys
        Dim sValue$: sValue = idList(iKey)
        If iFilter.Exists(sValue) Then
          Call iResult.Add(iShape)
          Exit For
        End If
      Next iKey
    End If
  Next iShape
  Set FilterPageIDs = iResult
End Function

' ========
Private Function GetSelectedConnector() As Visio.Shape
  Dim iSelected As Visio.Selection: Set iSelected = Application.ActiveWindow.Selection
  If iSelected.Count <> 1 Then
    Call MsgBox("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>", vbExclamation)
    Exit Function
  End If
  Dim iConnector As Visio.Shape: Set iConnector = iSelected(1)
  If iConnector.Connects.Count = 0 Then
    Call MsgBox("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>", vbExclamation)
    Exit Function
  End If
  Set GetSelectedConnector = iConnector
End Function

Private Function PromptAlignGap() As Double
  Dim sInput$: sInput = InputBox("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>", Default:="10")
  If sInput = vbNullString Then _
    Exit Function
  If Not IsNumeric(sInput) Then
    Call MsgBox("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>", vbExclamation)
    Exit Function
  End If
  PromptAlignGap = CDbl(sInput)
End Function

Private Function Convert1251(sText$) As String
  If sText = "" Then _
    Exit Function
  
  Dim nChr&
  For nChr = 1 To VBA.Len(sText)
    Dim aChr$: aChr = VBA.Mid$(sText, nChr, 1)
    Dim uniChr&: uniChr = VBA.AscW(aChr)
    If uniChr < 256 And uniChr > 127 Then _
      aChr = VBA.Chr(uniChr)
    Convert1251 = Convert1251 & aChr
  Next nChr
End Function

Private Function ExtractShapePrefix(sText$) As String
  Dim nChr&
  For nChr = 1 To VBA.Len(sText) Step 1
    If VBA.Mid$(sText, nChr, 1) Like "[<5B>-<2D><>a-zA-Z]" Then
      nChr = nChr - 1
      Exit For
    End If
  Next nChr
  If nChr = 0 Then _
    Exit Function
  
  Dim sResult$: sResult = VBA.Left(sText, nChr)
  If VBA.InStr(1, sResult, " ", vbTextCompare) = 0 Then _
    Exit Function
  
  ExtractShapePrefix = VBA.Trim(VBA.Left(sResult, VBA.InStrRev(sResult, " ")))
End Function

Private Function SplitPrefix(sPrefix$) As Scripting.Dictionary
  Dim iResult As New Scripting.Dictionary
  If VBA.InStr(1, sPrefix, "(") = 0 Then
    Call iResult.Add(sPrefix, sPrefix)
    Set SplitPrefix = iResult
    Exit Function
  End If
  
  Dim nStart&: nStart = -1
  Dim nChr&
  For nChr = 1 To VBA.Len(sPrefix) Step 1
    Dim aChr$: aChr = VBA.Mid$(sPrefix, nChr, 1)
    If aChr = "(" Then
      nStart = nChr
    ElseIf aChr = ")" Then
      If nStart <> -1 And nStart + 1 < nChr Then
        Dim sID$: sID = VBA.Trim(VBA.Mid$(sPrefix, nStart + 1, nChr - nStart - 1))
        If sID <> vbNullString Then
          On Error Resume Next
          Call iResult.Add(sID, sID)
          On Error GoTo 0
        End If
        nStart = -1
      End If
    End If
  Next nChr
  If iResult.Count = 0 Then _
    Call iResult.Add(sPrefix, sPrefix)
  Set SplitPrefix = iResult
End Function