433 lines
14 KiB
QBasic
433 lines
14 KiB
QBasic
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 = "Ñîåäèíèòåëü"
|
||
|
||
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("Âûäåëèòå ôèãóðó", vbExclamation)
|
||
Exit Sub
|
||
End If
|
||
Call GlobalUndo.BeginScope("Óâåëè÷åíèå øèðèíû")
|
||
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("Âûäåëèòå ôèãóðó", vbExclamation)
|
||
Exit Sub
|
||
End If
|
||
Call GlobalUndo.BeginScope("Óìåíüøåíèå øèðèíû")
|
||
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("Ñîçäàòü ñâÿçè")
|
||
|
||
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("Ïåðåíåñòè êîíöû")
|
||
|
||
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("Âûðàâíèâàíèå")
|
||
|
||
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("Âûðàâíèâàíèå")
|
||
|
||
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("Âûäåëèòå Ýëåìåíò", 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("Âûäåëèòå Ýëåìåíò", 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("Âûáåðèòå ñîåäèíèòåëü", vbExclamation)
|
||
Exit Function
|
||
End If
|
||
Dim iConnector As Visio.Shape: Set iConnector = iSelected(1)
|
||
If iConnector.Connects.Count = 0 Then
|
||
Call MsgBox("Âûáðàííûé ñîåäèíèòåëü äîëæåí áûòü ïðèêðåëïåí ê ôèãóðàì", vbExclamation)
|
||
Exit Function
|
||
End If
|
||
Set GetSelectedConnector = iConnector
|
||
End Function
|
||
|
||
Private Function PromptAlignGap() As Double
|
||
Dim sInput$: sInput = InputBox("Ââåäèòå ïîðîãîâîå ðàçëè÷èå â ìèëëèìåòðàõ", Default:="10")
|
||
If sInput = vbNullString Then _
|
||
Exit Function
|
||
If Not IsNumeric(sInput) Then
|
||
Call MsgBox("Ââåäèòå ÷èñëî", 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 "[à-ÿ¸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
|