Initial commit
This commit is contained in:
IRBorisov
commit
306e18c4f8
38
VBAMake.txt
Normal file
38
VBAMake.txt
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
# == Properties Section ==
|
||||
# configuration properties
|
||||
# use .ini format to define properties
|
||||
# mandatory properties: name, artifact_home, source_home
|
||||
|
||||
id = Concept-Hierarchy
|
||||
name = Концепт-Иерархия
|
||||
description = Технология визуализации и преобразования формы представления иерархий
|
||||
artifact_home = Концепт-Иерархия
|
||||
source_home = Concept-Hierarchy
|
||||
install_home = \\fs1.concept.ru\projects\10 Автоматизация деятельности\01 Высокие технологии\Концепт-Иерархия
|
||||
|
||||
%%
|
||||
# === Build section ===
|
||||
# Available commands:
|
||||
# build LOCAL_MANIFEST
|
||||
# copy LOCAL_SOURCE -> [LOCAL_ARTIFACT]
|
||||
# save_as LOCAL_ARTIFACT -> LOCAL_ARTIFACT
|
||||
# run LOCAL_SOURCE.bat
|
||||
|
||||
build script\manifest.txt
|
||||
save_as Иерархизатор.vsdm -> 30 Иерархизатор.vstm
|
||||
copy distr\!Readme.docx
|
||||
copy distr\Пример входных данных.xlsx
|
||||
|
||||
%%
|
||||
# === Install section ==
|
||||
# Available commands:
|
||||
# install LOCAL_ARTIFACT -> [INSTALL_PATH]
|
||||
# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE]
|
||||
# run LOCAL_ARTIFACT.bat <- [PARAMETERS]
|
||||
# run APPLICATION <- [PARAMETERS]
|
||||
|
||||
install Иерархизатор.vsdm
|
||||
install !Readme.docx
|
||||
install Пример входных данных.xlsx
|
||||
|
||||
add_template 30 Иерархизатор.vstm
|
||||
BIN
distr/!Readme.docx
Normal file
BIN
distr/!Readme.docx
Normal file
Binary file not shown.
BIN
distr/Пример входных данных.xlsx
Normal file
BIN
distr/Пример входных данных.xlsx
Normal file
Binary file not shown.
93
script/manifest.txt
Normal file
93
script/manifest.txt
Normal file
|
|
@ -0,0 +1,93 @@
|
|||
# == Properties Section ==
|
||||
# configuration properties
|
||||
# use .ini format to define properties
|
||||
# mandatory properties: name, artifact
|
||||
|
||||
name = Иерархизатор.vsdm
|
||||
artifact = Иерархизатор.vsdm
|
||||
|
||||
%%
|
||||
# === Imports Section ===
|
||||
# Hierarchy of folders and files
|
||||
# Use Tabulator to mark next level in hierarchy
|
||||
# All folders are nested into SharedHome path
|
||||
|
||||
dev
|
||||
DevTester.bas
|
||||
|
||||
api
|
||||
ex_WinAPI.bas
|
||||
API_VsoWrapper.cls
|
||||
API_XLWrapper.cls
|
||||
API_WordWrapper.cls
|
||||
API_UserInteraction.cls
|
||||
|
||||
utility
|
||||
ex_VBA.bas
|
||||
ex_Collection.bas
|
||||
ex_DataPreparation.bas
|
||||
ex_Color.bas
|
||||
ex_Version.bas
|
||||
|
||||
API_DistrManifest.cls
|
||||
API_JSON.cls
|
||||
CDS_Factorizator.cls
|
||||
CDS_Graph.cls
|
||||
CDS_Node.cls
|
||||
CDS_Edge.cls
|
||||
CDS_NodeSH.cls
|
||||
CDS_StaticHierarchy.cls
|
||||
|
||||
visio
|
||||
z_VsoUtilities.bas
|
||||
z_CCVsoExtension.bas
|
||||
z_VsoGraph.bas
|
||||
API_UndoWrapper.cls
|
||||
|
||||
word
|
||||
ex_Word.bas
|
||||
|
||||
ui
|
||||
CSE_ProgressBar.frm
|
||||
|
||||
%%
|
||||
# === Source Code Section ==
|
||||
# Hierarchy of folders and files
|
||||
# Use Tabulator to mark next level in hierarchy
|
||||
# All folders are nested into SourceHome path
|
||||
|
||||
src
|
||||
MasterDlg.frm
|
||||
|
||||
DevHelper.bas
|
||||
Declarations.bas
|
||||
DataAccess.bas
|
||||
Main.bas
|
||||
MainImpl.bas
|
||||
z_UIRibbon.bas
|
||||
z_UIMessages.bas
|
||||
|
||||
VisioNode.cls
|
||||
LayoutConstruction.cls
|
||||
|
||||
%%
|
||||
# ===== UI Section =======
|
||||
# Pairs of path to UI elements, use " -> " delimiter
|
||||
# First component is a path relative to SourceHome\ui folders
|
||||
# Second component is internal path inside project file
|
||||
|
||||
.rels -> _rels\.rels
|
||||
customUI1.xml -> visio\customUI\customUI1.xml
|
||||
|
||||
%%
|
||||
# === References Section ===
|
||||
# List dependencies in one of the formats
|
||||
# global : GLOBAL_NAME
|
||||
# guid : {REGISTERED_GUID}
|
||||
# file : PATH_TO_LIBRARY
|
||||
|
||||
global : MSForms
|
||||
global : Shell32
|
||||
global : Scripting
|
||||
global : Excel
|
||||
global : Word
|
||||
BIN
skeleton/Иерархизатор.vsdm
Normal file
BIN
skeleton/Иерархизатор.vsdm
Normal file
Binary file not shown.
97
src/DataAccess.bas
Normal file
97
src/DataAccess.bas
Normal file
|
|
@ -0,0 +1,97 @@
|
|||
Attribute VB_Name = "DataAccess"
|
||||
Option Explicit
|
||||
|
||||
Public Function MainPage() As Visio.Page
|
||||
Set MainPage = Application.ActiveDocument.Pages(1)
|
||||
End Function
|
||||
|
||||
Public Function GetRankMaster(nRank&) As Visio.Master
|
||||
Dim iMaster As Visio.Master: Set iMaster = FindMaster(ThisDocument, MASTER_RANK & nRank)
|
||||
If iMaster Is Nothing Then
|
||||
Set GetRankMaster = GetRankMaster(nRank - 1)
|
||||
Else
|
||||
Set GetRankMaster = iMaster
|
||||
End If
|
||||
End Function
|
||||
|
||||
Public Function GetConnectionMaster(nMode As TLayout) As Visio.Master
|
||||
Select Case nMode
|
||||
Case T_LAYOUT_HORIZONTAL: Set GetConnectionMaster = FindMaster(ThisDocument, MASTER_CONNECT_HOR)
|
||||
Case T_LAYOUT_VERTICAL: Set GetConnectionMaster = FindMaster(ThisDocument, MASTER_CONNECT_VERT)
|
||||
Case T_LAYOUT_COLUMN_LEFT: Set GetConnectionMaster = FindMaster(ThisDocument, MASTER_CONNECT_HOR)
|
||||
Case T_LAYOUT_COLUMN_RIGHT: Set GetConnectionMaster = FindMaster(ThisDocument, MASTER_CONNECT_HOR)
|
||||
Case Else: Set GetConnectionMaster = FindMaster(ThisDocument, MASTER_CONNECT_VERT)
|
||||
End Select
|
||||
End Function
|
||||
|
||||
Public Function GetRankWidth(nRank&) As Double
|
||||
GetRankWidth = GetRankMaster(nRank).Shapes(1).CellsU("Width")
|
||||
End Function
|
||||
|
||||
Public Function GetRanksBaseY() As Scripting.Dictionary
|
||||
Dim iBases As New Scripting.Dictionary
|
||||
Dim nRank&
|
||||
Dim baseY As Double: baseY = 0
|
||||
For nRank = 1 To TREE_MAX_RANK Step 1
|
||||
Dim iPrototype As Visio.Shape: Set iPrototype = GetRankMaster(nRank).Shapes(1)
|
||||
If Not iPrototype Is Nothing Then
|
||||
iBases(nRank) = baseY - iPrototype.CellsU("Height") / 2#
|
||||
baseY = baseY - iPrototype.CellsU("Height") - GAP_RANK
|
||||
End If
|
||||
Next nRank
|
||||
Set GetRanksBaseY = iBases
|
||||
End Function
|
||||
|
||||
Public Function GetChildrenOf(target As Visio.Shape) As Collection
|
||||
Set GetChildrenOf = New Collection
|
||||
Dim cnt As Visio.Connect
|
||||
For Each cnt In target.FromConnects
|
||||
Dim connector As Visio.Shape: Set connector = cnt.FromSheet
|
||||
If connector.Connects(1).ToSheet Is target And connector.Connects.Count = 2 Then _
|
||||
Call GetChildrenOf.Add(connector.Connects(2).ToSheet)
|
||||
Next cnt
|
||||
End Function
|
||||
|
||||
Public Function ExrtactXLPayload(iSource As Excel.Worksheet, nRow&) As VisioNode
|
||||
Dim iPayload As New VisioNode
|
||||
iPayload.text_ = iSource.Cells(nRow, 2)
|
||||
If iSource.Cells(nRow, 1).Interior.ColorIndex <> -4142 Then _
|
||||
iPayload.color_ = iSource.Cells(nRow, 1).Interior.Color
|
||||
Set ExrtactXLPayload = iPayload
|
||||
End Function
|
||||
|
||||
Public Function ExtractWordPayload(iSource As Word.Range) As VisioNode
|
||||
Dim sText$: sText = TrimWhitespace(iSource.Text)
|
||||
If sText = vbNullString Then _
|
||||
Exit Function
|
||||
|
||||
Dim nColor&: nColor = iSource.Shading.BackgroundPatternColor
|
||||
nColor = IIf(nColor = wdColorAutomatic, COLOR_DEFAULT, ColorGetRGB(iSource.Font.Shading.BackgroundPatternColor, iSource.Document))
|
||||
|
||||
Dim iPayload As New VisioNode
|
||||
iPayload.text_ = sText
|
||||
iPayload.color_ = nColor
|
||||
Set ExtractWordPayload = iPayload
|
||||
End Function
|
||||
|
||||
Public Function ExtractVsoPayload(target As Visio.Shape) As VisioNode
|
||||
Dim iPayload As New VisioNode
|
||||
iPayload.text_ = target.Text
|
||||
iPayload.color_ = ConvertStringToRGB(target.CellsU("FillForegnd").ResultStrU(""))
|
||||
Set iPayload.shape_ = target
|
||||
Set ExtractVsoPayload = iPayload
|
||||
End Function
|
||||
|
||||
Public Function WordStyleForRank(wordDoc As Word.Document, nRank As Integer) As String
|
||||
WordStyleForRank = "Îáû÷íûé"
|
||||
If nRank < 1 Or nRank > WORD_HEADING_MAX_LEVEL Then _
|
||||
Exit Function
|
||||
|
||||
Dim sStyle$: sStyle = "Çàãîëîâîê " & nRank & " Íóìåðîâàííûé"
|
||||
If WordStyleExists(wordDoc, sStyle) Then
|
||||
WordStyleForRank = sStyle
|
||||
Else
|
||||
WordStyleForRank = "Çàãîëîâîê " & nRank
|
||||
End If
|
||||
End Function
|
||||
|
||||
42
src/Declarations.bas
Normal file
42
src/Declarations.bas
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
Attribute VB_Name = "Declarations"
|
||||
Option Explicit
|
||||
|
||||
Public Const TREE_MAX_RANK As Integer = 30
|
||||
|
||||
Public Const COLOR_DEFAULT = -1
|
||||
|
||||
Public Const FLOAT_ACCURACY As Double = 0.001
|
||||
|
||||
Public Const GAP_VERTICAL = 5# / 25.4
|
||||
Public Const GAP_HORIZONTAL = 5# / 25.4
|
||||
Public Const GAP_VERT_ADJUSTMENT_TO_HOR = 10# / 25.4
|
||||
Public Const GAP_RANK = 10# / 25.4
|
||||
|
||||
Public Const MASTER_CONNECT_HOR = "Ãîðèçîíòàëüíàÿ ñòðåëêà"
|
||||
Public Const MASTER_CONNECT_VERT = "Âåðòèêàëüíàÿ ñòðåëêà"
|
||||
Public Const MASTER_RANK = "Óð"
|
||||
|
||||
Public Const SHAPE_RANK_MASTER = "#Lvl"
|
||||
|
||||
Public Const PREFIX_NODE = "#N"
|
||||
Public Const PREFIX_CONNECTOR = "#C"
|
||||
|
||||
' Layout modes
|
||||
Public Enum TLayout
|
||||
T_LAYOUT_VERTICAL ' y-based
|
||||
T_LAYOUT_HORIZONTAL ' x-based
|
||||
T_LAYOUT_RADIAL ' distance based
|
||||
T_LAYOUT_COLUMN_RIGHT ' right column
|
||||
T_LAYOUT_COLUMN_LEFT ' left column
|
||||
End Enum
|
||||
|
||||
' Input / output modes for conversion
|
||||
Public Enum IOMode
|
||||
MODE_EXCEL
|
||||
MODE_WORD
|
||||
MODE_VISIO
|
||||
End Enum
|
||||
|
||||
' ========== Word declarations ==========
|
||||
Public Const WORD_HEADING_MAX_LEVEL = 9
|
||||
Public Const EXPORT_TEMPLATE_PATH = "\Microsoft\Øàáëîíû\01 Ðàáî÷èé äîêóìåíò.dotx"
|
||||
21
src/DevHelper.bas
Normal file
21
src/DevHelper.bas
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
Attribute VB_Name = "DevHelper"
|
||||
Option Private Module
|
||||
Option Explicit
|
||||
|
||||
Public Function Dev_PrepareSkeleton()
|
||||
' Do nothing
|
||||
End Function
|
||||
|
||||
Public Function Dev_ManualRunTest()
|
||||
Dim sSuite$: sSuite = "s_UndoWrapper"
|
||||
Dim sTest$: sTest = "t_BasicUndo"
|
||||
Dim sMsg$: sMsg = Dev_RunTest(sSuite, sTest)
|
||||
Debug.Print sMsg
|
||||
Call MsgBox(sMsg)
|
||||
End Function
|
||||
|
||||
Public Function Dev_GetTestSuite(sName$) As Object
|
||||
Select Case sName
|
||||
' Case "s_UndoWrapper": Set Dev_GetTestSuite = New s_UndoWrapper
|
||||
End Select
|
||||
End Function
|
||||
201
src/LayoutConstruction.cls
Normal file
201
src/LayoutConstruction.cls
Normal file
|
|
@ -0,0 +1,201 @@
|
|||
VERSION 1.0 CLASS
|
||||
BEGIN
|
||||
MultiUse = -1 'True
|
||||
END
|
||||
Attribute VB_Name = "LayoutConstruction"
|
||||
Attribute VB_GlobalNameSpace = False
|
||||
Attribute VB_Creatable = False
|
||||
Attribute VB_PredeclaredId = False
|
||||
Attribute VB_Exposed = False
|
||||
Option Explicit
|
||||
|
||||
Private page_ As Visio.Page
|
||||
Private data_ As CDS_StaticHierarchy
|
||||
Private autoVertical_ As Boolean
|
||||
|
||||
Private width_ As Scripting.Dictionary
|
||||
|
||||
Private Const SIZING_FACTOR_LIMIT = 1.3
|
||||
|
||||
Public Function Init(iPage As Visio.Page, ByRef iData As CDS_StaticHierarchy, bAutoVertical As Boolean)
|
||||
Set page_ = iPage
|
||||
Set data_ = iData
|
||||
autoVertical_ = bAutoVertical
|
||||
End Function
|
||||
|
||||
Public Function ConstructHNodes()
|
||||
Dim ranksLast As New Scripting.Dictionary
|
||||
Dim ranksY As Scripting.Dictionary: Set ranksY = GetRanksBaseY
|
||||
Dim lastInsert As Visio.Shape
|
||||
|
||||
Dim iNode As CDS_NodeSH
|
||||
Dim iParent As Visio.Shape
|
||||
For Each iNode In data_.nodes_
|
||||
Dim nRank&: nRank = iNode.rank_
|
||||
Dim nLayout As TLayout: nLayout = GetLayoutFor(iNode.parent_)
|
||||
Dim iNewShape As Visio.Shape: Set iNewShape = CreateNodeShape(iNode)
|
||||
Set iNode.data_.shape_ = iNewShape
|
||||
|
||||
If iNode.parent_ Is Nothing Then
|
||||
Set iParent = Nothing
|
||||
Else
|
||||
Set iParent = iNode.parent_.data_.shape_
|
||||
End If
|
||||
|
||||
If nLayout = T_LAYOUT_HORIZONTAL Then
|
||||
If Not ranksLast.Exists(nRank) Then
|
||||
iNewShape.CellsU("PinY") = ranksY(nRank) - iNewShape.CellsU("Height") / 2#
|
||||
Else
|
||||
Call MoveShapeAfterHorizontal(iNewShape, ranksLast(nRank))
|
||||
End If
|
||||
Set ranksLast(nRank) = iNewShape
|
||||
Set lastInsert = Nothing
|
||||
Else
|
||||
If lastInsert Is Nothing Then
|
||||
Call MoveShapeAfterVertical(iNewShape, iParent, GAP_RANK)
|
||||
Else
|
||||
Call MoveShapeAfterVertical(iNewShape, lastInsert, GAP_VERTICAL)
|
||||
End If
|
||||
Set lastInsert = iNewShape
|
||||
End If
|
||||
|
||||
If iNode.children_.Count = 0 Then _
|
||||
Call TryOptimizeHeight(iNewShape, iNode.rank_, nLayout)
|
||||
|
||||
If Not iParent Is Nothing Then _
|
||||
Call ConnectNodes(iParent, iNewShape, nLayout)
|
||||
|
||||
Call CSE_ProgressBar.IncrementA
|
||||
Next iNode
|
||||
End Function
|
||||
|
||||
Public Function CalculateWidth()
|
||||
Set width_ = New Scripting.Dictionary
|
||||
Call GetWidthFor(data_.nodes_(1))
|
||||
End Function
|
||||
|
||||
Public Function RepositionAll()
|
||||
Call SetPositionFor(data_.nodes_(1), dBaseX:=0)
|
||||
End Function
|
||||
|
||||
' ==============
|
||||
Private Function GetWidthFor(iNode As CDS_NodeSH) As Double
|
||||
If width_.Exists(iNode.id_) Then
|
||||
GetWidthFor = width_(iNode.id_)
|
||||
Else
|
||||
width_(iNode.id_) = CalculateWidthFor(iNode)
|
||||
GetWidthFor = width_(iNode.id_)
|
||||
End If
|
||||
End Function
|
||||
|
||||
Private Function CalculateWidthFor(iNode As CDS_NodeSH) As Double
|
||||
Dim dChildWidth As Double
|
||||
Dim iChild As CDS_NodeSH
|
||||
Dim dNodeWidth As Double: dNodeWidth = iNode.data_.shape_.CellsU("Width")
|
||||
If iNode.children_.Count = 0 Then
|
||||
CalculateWidthFor = dNodeWidth
|
||||
ElseIf GetLayoutFor(iNode) = T_LAYOUT_VERTICAL Then
|
||||
dNodeWidth = dNodeWidth
|
||||
For Each iChild In iNode.children_
|
||||
dChildWidth = GetWidthFor(iChild)
|
||||
If dNodeWidth < dChildWidth Then _
|
||||
dNodeWidth = dChildWidth
|
||||
Next iChild
|
||||
CalculateWidthFor = dNodeWidth + GAP_VERT_ADJUSTMENT_TO_HOR
|
||||
Else
|
||||
Dim dAccumulated As Double: dAccumulated = -GAP_HORIZONTAL
|
||||
For Each iChild In iNode.children_
|
||||
dAccumulated = dAccumulated + GAP_HORIZONTAL + GetWidthFor(iChild)
|
||||
Next iChild
|
||||
|
||||
Dim dRankWidth As Double: dRankWidth = GetRankWidth(iNode.rank_)
|
||||
If dAccumulated < dRankWidth Then _
|
||||
dAccumulated = dRankWidth
|
||||
If dAccumulated < dNodeWidth Then _
|
||||
dAccumulated = dNodeWidth
|
||||
CalculateWidthFor = dAccumulated
|
||||
End If
|
||||
End Function
|
||||
|
||||
Private Function SetPositionFor(iNode As CDS_NodeSH, dBaseX As Double)
|
||||
Dim iTarget As Visio.Shape: Set iTarget = iNode.data_.shape_
|
||||
Dim dNodeWidth As Double: dNodeWidth = width_(iNode.id_)
|
||||
Dim iChild As CDS_NodeSH
|
||||
|
||||
Call CSE_ProgressBar.IncrementA
|
||||
If iNode.children_.Count = 0 Then
|
||||
iTarget.CellsU("PinX") = dBaseX + dNodeWidth / 2#
|
||||
ElseIf GetLayoutFor(iNode) = T_LAYOUT_VERTICAL Then
|
||||
iTarget.CellsU("PinX") = dBaseX + iTarget.CellsU("Width") / 2# + GAP_VERT_ADJUSTMENT_TO_HOR
|
||||
For Each iChild In iNode.children_
|
||||
iChild.data_.shape_.CellsU("PinX") = dBaseX + iChild.data_.shape_.CellsU("Width") / 2# + GAP_VERT_ADJUSTMENT_TO_HOR
|
||||
Next iChild
|
||||
Call CSE_ProgressBar.IncrementA(iNode.children_.Count)
|
||||
Else ' Horizontal
|
||||
Dim newX As Double: newX = dBaseX
|
||||
If iNode.children_.Count = 1 And dNodeWidth > width_(iNode.children_(1).id_) Then _
|
||||
newX = dBaseX + dNodeWidth / 2# - width_(iNode.children_(1).id_) / 2#
|
||||
For Each iChild In iNode.children_
|
||||
Call SetPositionFor(iChild, newX)
|
||||
newX = newX + width_(iChild.id_) + GAP_HORIZONTAL
|
||||
Next iChild
|
||||
iTarget.CellsU("PinX") = iNode.children_(1).data_.shape_.CellsU("PinX") / 2# _
|
||||
+ iNode.children_(iNode.children_.Count).data_.shape_.CellsU("PinX") / 2#
|
||||
End If
|
||||
End Function
|
||||
|
||||
Private Function MoveShapeAfterVertical(sh1 As Visio.Shape, sh2 As Visio.Shape, dGap As Double)
|
||||
Dim dPinx As Double: dPinx = sh2.CellsU("PinX") - sh1.CellsU("Width") / 2# + sh2.CellsU("Width") / 2#
|
||||
Dim dPiny As Double: dPiny = sh2.CellsU("PinY") - dGap - sh2.CellsU("Height") / 2# - sh1.CellsU("Height") / 2#
|
||||
Call sh1.SetCenter(dPinx, dPiny)
|
||||
End Function
|
||||
|
||||
Private Function MoveShapeAfterHorizontal(sh1 As Visio.Shape, sh2 As Visio.Shape)
|
||||
Dim dPinx As Double: dPinx = sh2.CellsU("PinX") + GAP_HORIZONTAL + sh2.CellsU("Width") / 2# + sh1.CellsU("Width") / 2#
|
||||
Dim dPiny As Double: dPiny = sh2.CellsU("PinY") + sh2.CellsU("Height") / 2# - sh1.CellsU("Height") / 2#
|
||||
Call sh1.SetCenter(dPinx, dPiny)
|
||||
End Function
|
||||
|
||||
Private Function GetLayoutFor(iNode As CDS_NodeSH) As TLayout
|
||||
If iNode Is Nothing Then
|
||||
GetLayoutFor = T_LAYOUT_HORIZONTAL
|
||||
ElseIf iNode.parent_ Is Nothing Then
|
||||
GetLayoutFor = T_LAYOUT_HORIZONTAL
|
||||
ElseIf iNode.children_.Count <= 1 Then
|
||||
GetLayoutFor = T_LAYOUT_HORIZONTAL
|
||||
ElseIf Not autoVertical_ And iNode.rank_ + 1 <> data_.MaxDepth Then
|
||||
GetLayoutFor = T_LAYOUT_HORIZONTAL
|
||||
ElseIf iNode.descendantsCount_ = iNode.children_.Count Then
|
||||
GetLayoutFor = T_LAYOUT_VERTICAL
|
||||
Else
|
||||
GetLayoutFor = T_LAYOUT_HORIZONTAL
|
||||
End If
|
||||
End Function
|
||||
|
||||
Private Function CreateNodeShape(ByRef iNode As CDS_NodeSH) As Visio.Shape
|
||||
Dim iShape As Visio.Shape: Set iShape = page_.Drop(GetRankMaster(iNode.rank_), 0, 0)
|
||||
With iShape
|
||||
.Text = iNode.data_.text_
|
||||
.Name = PREFIX_NODE & iNode.id_
|
||||
.CellsSRC(visSectionObject, visRowLock, visLockDelete).FormulaU = "0"
|
||||
If iNode.data_.color_ <> COLOR_DEFAULT Then _
|
||||
.CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = ConvertRGBtoString(iNode.data_.color_)
|
||||
End With
|
||||
Set CreateNodeShape = iShape
|
||||
End Function
|
||||
|
||||
Private Function TryOptimizeHeight(iShape As Visio.Shape, nRank&, nLayout As TLayout)
|
||||
Dim dGap As Double: dGap = IIf(nLayout = T_LAYOUT_HORIZONTAL, GAP_RANK, GAP_VERTICAL)
|
||||
Dim iPrototype As Visio.Master: Set iPrototype = GetRankMaster(nRank)
|
||||
Dim kFactor As Double: kFactor = VBA.Sqr(iShape.CellsU("Width") / iPrototype.Shapes(1).CellsU("Width"))
|
||||
If kFactor < SIZING_FACTOR_LIMIT Then _
|
||||
Exit Function
|
||||
|
||||
Dim dLeft As Double: dLeft = iShape.CellsU("PinX") - iShape.CellsU("Width") / 2#
|
||||
Dim dTop As Double: dTop = iShape.CellsU("PinY") + iShape.CellsU("Height") / 2#
|
||||
kFactor = VBA.Int(kFactor) + 1
|
||||
iShape.CellsU("Height") = iPrototype.Shapes(1).CellsU("Height") * kFactor + dGap * (kFactor - 1)
|
||||
iShape.CellsU("PinY") = dTop - iShape.CellsU("Height") / 2#
|
||||
If nLayout = T_LAYOUT_HORIZONTAL Then _
|
||||
iShape.CellsU("PinX") = dLeft + iShape.CellsU("Width") / 2#
|
||||
End Function
|
||||
278
src/Main.bas
Normal file
278
src/Main.bas
Normal file
|
|
@ -0,0 +1,278 @@
|
|||
Attribute VB_Name = "Main"
|
||||
Option Explicit
|
||||
|
||||
Public Const PRODUCT_VERSION = "1.2.0"
|
||||
Public Const PRODUCT_NAME = "Concept-Hierarchy"
|
||||
|
||||
Public g_VersionTimer As Long
|
||||
|
||||
Public Sub StartVersionCheck()
|
||||
g_VersionTimer = SetTimer(0, 0, CP_VERSION_MSG_DELAY, AddressOf OnVersionCheck)
|
||||
End Sub
|
||||
|
||||
Public Function OnVersionCheck(ByVal nHwnd As Long, ByVal uMsg As Long, ByVal nEvent As Long, ByVal nTime As Long)
|
||||
Call KillTimer(0, g_VersionTimer)
|
||||
Call VersionValidate(PRODUCT_NAME, PRODUCT_VERSION)
|
||||
End Function
|
||||
|
||||
Public Sub RunGotoLinkBegin()
|
||||
Attribute RunGotoLinkBegin.VB_ProcData.VB_Invoke_Func = "Q"
|
||||
Call CC_GotoLinkBegin
|
||||
End Sub
|
||||
|
||||
Public Sub RunGotoLinkEnd()
|
||||
Call CC_GotoLinkEnd
|
||||
End Sub
|
||||
|
||||
Public Sub RunImportWord()
|
||||
Dim sFile$: sFile = UserInteraction.PromptFileFilter( _
|
||||
sInitialPath:=Visio.ActiveDocument.Path, _
|
||||
sDescription:="Âûáåðèòå ôàéë, ïî ñòðóêòóðå êîòîðîãî Âû õîòèòå ïîñòðîèòü äåðåâî", _
|
||||
sFilter:="*.docx;*.doc;*.docm", _
|
||||
sTitle:="Äîêóìåíò Word", _
|
||||
bNewApplication:=True)
|
||||
If sFile = vbNullString Then _
|
||||
Exit Sub
|
||||
Dim iData As CDS_StaticHierarchy: Set iData = ScanHierarchy(sFile, MODE_WORD)
|
||||
If iData Is Nothing Then _
|
||||
Exit Sub
|
||||
|
||||
Call OutputHierarchy(iData, MODE_VISIO)
|
||||
End Sub
|
||||
|
||||
Public Sub RunImportXL()
|
||||
Dim sFile$: sFile = UserInteraction.PromptFileFilter( _
|
||||
sInitialPath:=Visio.ActiveDocument.Path, _
|
||||
sDescription:="Âûáåðèòå ôàéë, ïî ñòðóêòóðå êîòîðîãî Âû õîòèòå ïîñòðîèòü äåðåâî", _
|
||||
sFilter:="*.xlsx;*.xls;*.xlsm", _
|
||||
sTitle:="Òàáëèöà Excel", _
|
||||
bNewApplication:=True)
|
||||
If sFile = vbNullString Then _
|
||||
Exit Sub
|
||||
Dim iData As CDS_StaticHierarchy: Set iData = ScanHierarchy(sFile, MODE_EXCEL)
|
||||
If iData Is Nothing Then _
|
||||
Exit Sub
|
||||
|
||||
Call OutputHierarchy(iData, MODE_VISIO)
|
||||
End Sub
|
||||
|
||||
Public Sub RunMaster()
|
||||
Call MasterDlg.Show
|
||||
If MasterDlg.bCanceled Then _
|
||||
Exit Sub
|
||||
|
||||
Dim iMode As IOMode: iMode = MasterDlg.InputMode
|
||||
Dim oMode As IOMode: oMode = MasterDlg.OutputMode
|
||||
Dim iLayout As TLayout: iLayout = MasterDlg.InputLayout
|
||||
Dim sFileName$: sFileName = MasterDlg.InputFile
|
||||
|
||||
If iMode <> MODE_VISIO And sFileName = vbNullString Then
|
||||
Call UserInteraction.ShowMessage(EM_FILENAME_EMPTY)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim iData As CDS_StaticHierarchy: Set iData = ScanHierarchy(sFileName, iMode, iLayout)
|
||||
If iData Is Nothing Then _
|
||||
Exit Sub
|
||||
|
||||
Call OutputHierarchy(iData, MasterDlg.OutputMode)
|
||||
End Sub
|
||||
|
||||
Public Sub RunClearScheme()
|
||||
Attribute RunClearScheme.VB_Description = "Î÷èñòêà ñòðóêòóðû"
|
||||
Attribute RunClearScheme.VB_ProcData.VB_Invoke_Func = "X"
|
||||
Call GlobalUndo.BeginScope("Î÷èñòêà ãåíåðèðîâàííûõ ôèãóð")
|
||||
|
||||
Call ClearGeneratedShapes(MainPage)
|
||||
Call VsoShowWholePage(MainPage)
|
||||
|
||||
Call GlobalUndo.EndScope
|
||||
End Sub
|
||||
|
||||
Public Sub RunRename()
|
||||
Attribute RunRename.VB_Description = "Àâòîíóìåðàöèÿ"
|
||||
Dim sel As Visio.Selection: Set sel = Visio.Application.ActiveWindow.Selection
|
||||
If sel.Count <> 1 Then
|
||||
Call UserInteraction.ShowMessage(EM_INVALID_SELECTION)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Call GlobalUndo.BeginScope("Íóìåðàöèÿ óçëîâ äåðåâà")
|
||||
|
||||
Call GenerateNamesFor(sel.Item(1))
|
||||
|
||||
Call GlobalUndo.EndScope
|
||||
End Sub
|
||||
|
||||
Public Sub RunTransform()
|
||||
Attribute RunTransform.VB_ProcData.VB_Invoke_Func = "Z"
|
||||
Dim sel As Visio.Selection: Set sel = Visio.Application.ActiveWindow.Selection
|
||||
If sel.Count <> 1 Then
|
||||
Call UserInteraction.ShowMessage(EM_INVALID_SELECTION)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Call GlobalUndo.BeginScope("Òðàíñôîðìàöèÿ ñòðóêòóðû")
|
||||
|
||||
Call TransformNodeLayout(sel.Item(1))
|
||||
|
||||
Call GlobalUndo.EndScope
|
||||
End Sub
|
||||
|
||||
Public Sub RunConnectColumns()
|
||||
Dim sel As Visio.Selection: Set sel = Visio.Application.ActiveWindow.Selection
|
||||
If sel.Count <> 1 Then
|
||||
Call UserInteraction.ShowMessage(EM_INVALID_SELECTION)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Call GlobalUndo.BeginScope("Ñòðåëêè ê êîëîíêàì")
|
||||
|
||||
Call ConnectColumns(sel.Item(1))
|
||||
|
||||
Call GlobalUndo.EndScope
|
||||
End Sub
|
||||
|
||||
Public Sub RunNewRankTemplate()
|
||||
Dim iMaster As Visio.Master
|
||||
Set iMaster = AddNewRankTemplate
|
||||
If Not iMaster Is Nothing Then _
|
||||
Call UserInteraction.ShowMessage(IM_NEW_TEMPLATE, iMaster.Name)
|
||||
End Sub
|
||||
|
||||
' =======
|
||||
Private Function ScanHierarchy(sFileName$, iMode As IOMode, Optional nLayout As TLayout = T_LAYOUT_HORIZONTAL) As CDS_StaticHierarchy
|
||||
Dim iData As CDS_StaticHierarchy
|
||||
Select Case iMode
|
||||
Case MODE_EXCEL: Set iData = ProcessExcel(sFileName)
|
||||
Case MODE_WORD: Set iData = ProcessWord(sFileName)
|
||||
Case MODE_VISIO: Set iData = ProcessVisio(VsoGetSelectedShapes(ThisDocument.Application), nLayout)
|
||||
End Select
|
||||
If iData Is Nothing Then _
|
||||
Exit Function
|
||||
If Not ValidateHierarchy(iData) Then
|
||||
Call UserInteraction.ShowMessage(EM_INVALID_STRUCTURE)
|
||||
Exit Function
|
||||
End If
|
||||
Set ScanHierarchy = iData
|
||||
End Function
|
||||
|
||||
Private Function OutputHierarchy(iData As CDS_StaticHierarchy, oMode As IOMode)
|
||||
Select Case oMode
|
||||
Case MODE_EXCEL: Call GenerateExcel(iData, Not MasterDlg.XLExportAsTree)
|
||||
Case MODE_WORD: Call GenerateWord(iData, MasterDlg.WordExportAsString)
|
||||
Case MODE_VISIO: Call GenerateVisio(MainPage, iData, MasterDlg.AutoLayout)
|
||||
End Select
|
||||
End Function
|
||||
|
||||
Private Function ProcessVisio(iShapes As Collection, nLayout As TLayout) As CDS_StaticHierarchy
|
||||
If iShapes.Count <> 1 Then
|
||||
Call UserInteraction.ShowMessage(EM_INVALID_SELECTION)
|
||||
Exit Function
|
||||
End If
|
||||
Set ProcessVisio = ScanVisioNode(iShapes(1), nLayout)
|
||||
End Function
|
||||
|
||||
Private Function ProcessExcel(sFileName$) As CDS_StaticHierarchy
|
||||
Dim xlApp As New API_XLWrapper
|
||||
If xlApp.OpenDocument(sFileName, bReadOnly:=True) Is Nothing Then
|
||||
Call UserInteraction.ShowMessage(EM_ERROR_LOADING_FILE)
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim iSource As Excel.Worksheet: Set iSource = xlApp.Document.Worksheets(1)
|
||||
Call CSE_ProgressBar.Init("Ñêàíèðîâàíèå òàáëèöû", maxVal:=iSource.UsedRange.Rows.Count, curVal:=1)
|
||||
Call CSE_ProgressBar.ShowModeless
|
||||
|
||||
Set ProcessExcel = ScanExcel(iSource)
|
||||
If ProcessExcel Is Nothing Then _
|
||||
Call UserInteraction.ShowMessage(EM_INVALID_FORMAT, xlApp.Document.Name)
|
||||
|
||||
Call Unload(CSE_ProgressBar)
|
||||
Call xlApp.ReleaseDocument
|
||||
End Function
|
||||
|
||||
Private Function ProcessWord(sFileName$) As CDS_StaticHierarchy
|
||||
Dim wordApp As New API_WordWrapper
|
||||
If wordApp.OpenDocument(sFileName, bReadOnly:=True) Is Nothing Then
|
||||
Call UserInteraction.ShowMessage(EM_ERROR_LOADING_FILE)
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Call CSE_ProgressBar.Init("Ñêàíèðîâàíèå òåêñòà äîêóìåíòà", maxVal:=wordApp.Document.Paragraphs.Count, curVal:=0)
|
||||
Call CSE_ProgressBar.ShowModeless
|
||||
|
||||
Set ProcessWord = ScanWord(wordApp.Document)
|
||||
If ProcessWord Is Nothing Then _
|
||||
Call UserInteraction.ShowMessage(EM_INVALID_FORMAT, wordApp.Document.Name)
|
||||
|
||||
Call Unload(CSE_ProgressBar)
|
||||
Call wordApp.ReleaseDocument
|
||||
End Function
|
||||
|
||||
Private Function GenerateWord(iData As CDS_StaticHierarchy, bAsString As Boolean)
|
||||
If Not bAsString And iData.MaxDepth > WORD_HEADING_MAX_LEVEL Then
|
||||
Call UserInteraction.ShowMessage(EM_WORD_MAX_LEVELS)
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim sTemplate$: sTemplate = VBA.Environ("AppData") & EXPORT_TEMPLATE_PATH
|
||||
Dim wordApp As New API_WordWrapper
|
||||
Dim iOutput As Word.Document: Set iOutput = wordApp.NewDocument(sTemplate)
|
||||
Call iOutput.Range.Delete
|
||||
|
||||
Call wordApp.PauseUI
|
||||
If Not bAsString Then
|
||||
Call Hierarchy2Word(iData, iOutput)
|
||||
Else
|
||||
Call CSE_ProgressBar.Init("Ãåíåðàöèÿ ñòðîê...", maxVal:=iData.Size, curVal:=1)
|
||||
Call CSE_ProgressBar.ShowModeless
|
||||
|
||||
Call Hierarchy2WordString(iData, iOutput)
|
||||
|
||||
Call Unload(CSE_ProgressBar)
|
||||
End If
|
||||
Call UserInteraction.ShowMessage(IM_EXPORT_OK, iData.Size, iData.MaxDepth)
|
||||
Call wordApp.ResumeUI
|
||||
End Function
|
||||
|
||||
Private Function GenerateExcel(iData As CDS_StaticHierarchy, bFlatData As Boolean)
|
||||
Dim xlApp As New API_XLWrapper
|
||||
Dim xlOut As Excel.Workbook: Set xlOut = xlApp.NewDocument
|
||||
|
||||
Call xlApp.PauseUI
|
||||
Call Hierarchy2XL(iData, xlOut.Worksheets(1), bFlatData)
|
||||
Call UserInteraction.ShowMessage(IM_EXPORT_OK, iData.Size, iData.MaxDepth)
|
||||
Call xlApp.ResumeUI
|
||||
End Function
|
||||
|
||||
Private Function GenerateVisio(iPage As Visio.Page, iData As CDS_StaticHierarchy, Optional bAutoVertical As Boolean = True)
|
||||
Call ClearGeneratedShapes(iPage)
|
||||
Dim iLayout As New LayoutConstruction: Call iLayout.Init(iPage, iData, bAutoVertical)
|
||||
|
||||
Dim vsoApp As New API_VsoWrapper: Call vsoApp.SetDocument(ThisDocument)
|
||||
Call vsoApp.PauseUI
|
||||
Call GlobalUndo.BeginScope("Ïîñòðîåíèå èåðàðõè÷åñêîãî äåðåâà")
|
||||
|
||||
Call CSE_ProgressBar.Init("Ñîçäàíèå óçëîâ è ñâÿçåé", maxVal:=iData.Size, curVal:=1)
|
||||
Call CSE_ProgressBar.ShowModeless
|
||||
|
||||
Call iLayout.ConstructHNodes
|
||||
DoEvents
|
||||
|
||||
Call CSE_ProgressBar.Init("Ðàñïîëîæåíèå óçëîâ", maxVal:=iData.Size)
|
||||
Call iLayout.CalculateWidth
|
||||
Call iLayout.RepositionAll
|
||||
|
||||
Call Unload(CSE_ProgressBar)
|
||||
|
||||
Call GlobalUndo.EndScope
|
||||
Call vsoApp.ResumeUI
|
||||
|
||||
Call iPage.ResizeToFitContents
|
||||
Call VsoShowWholePage(iPage)
|
||||
|
||||
Dim nWidth&: nWidth = iPage.PageSheet.CellsU("PageWidth").Result("mm")
|
||||
Dim nHeight&: nHeight = iPage.PageSheet.CellsU("PageHeight").Result("mm")
|
||||
Call UserInteraction.ShowMessage(IM_IMPORT_OK, iData.Size, iData.MaxDepth, nWidth, nHeight)
|
||||
End Function
|
||||
446
src/MainImpl.bas
Normal file
446
src/MainImpl.bas
Normal file
|
|
@ -0,0 +1,446 @@
|
|||
Attribute VB_Name = "MainImpl"
|
||||
Option Explicit
|
||||
|
||||
Public Function ClearGeneratedShapes(target As Visio.Page)
|
||||
Dim nItem&: nItem = 1
|
||||
Do While Not nItem > target.Shapes.Count
|
||||
Dim vsoShape As Shape: Set vsoShape = target.Shapes(nItem)
|
||||
Dim shpName$: shpName = vsoShape.Name
|
||||
If Left(shpName, 2) = "#N" Or Left(shpName, 2) = "#C" Then
|
||||
vsoShape.Delete
|
||||
nItem = 1
|
||||
Else
|
||||
nItem = nItem + 1
|
||||
End If
|
||||
Loop
|
||||
Call target.ResizeToFitContents
|
||||
End Function
|
||||
|
||||
Public Function ValidateHierarchy(target As CDS_StaticHierarchy) As Boolean
|
||||
ValidateHierarchy = False
|
||||
If target.nodes_.Count = 0 Then _
|
||||
Exit Function
|
||||
If target.nodes_(1).rank_ <> 1 Then _
|
||||
Exit Function
|
||||
|
||||
Dim iNode As CDS_NodeSH
|
||||
For Each iNode In target.nodes_
|
||||
If iNode.id_ <> 1 And iNode.rank_ <= 1 Then _
|
||||
Exit Function
|
||||
Next iNode
|
||||
|
||||
ValidateHierarchy = True
|
||||
End Function
|
||||
|
||||
Public Function ConnectNodes(shape1 As Visio.Shape, shape2 As Visio.Shape, nLayout As TLayout) As Boolean
|
||||
Dim iConnector As Visio.Shape: Set iConnector = CreateConnector(shape1, shape2, nLayout)
|
||||
iConnector.CellsSRC(visSectionObject, visRowLock, visLockDelete).FormulaU = "0"
|
||||
iConnector.Name = PREFIX_CONNECTOR & shape1.ID & "-" & shape2.ID
|
||||
End Function
|
||||
|
||||
Public Function CreateConnector(sh1 As Visio.Shape, sh2 As Visio.Shape, nMode As TLayout) As Visio.Shape
|
||||
Dim iPage As Visio.Page: Set iPage = sh1.ContainingPage
|
||||
Dim prototype As Visio.Master: Set prototype = GetConnectionMaster(nMode)
|
||||
|
||||
Call sh1.AutoConnect(sh2, visAutoConnectDirNone, prototype)
|
||||
Dim connector As Visio.Shape: Set connector = iPage.Shapes(iPage.Shapes.Count)
|
||||
Select Case nMode
|
||||
Case T_LAYOUT_HORIZONTAL
|
||||
Call connector.CellsU("BeginX").GlueTo(sh1.CellsSRC(7, 0, 0))
|
||||
Call connector.CellsU("EndX").GlueTo(sh2.CellsSRC(7, 1, 0))
|
||||
|
||||
Case T_LAYOUT_COLUMN_LEFT
|
||||
Call connector.CellsU("BeginX").GlueTo(sh1.CellsSRC(7, 0, 0))
|
||||
Call connector.CellsU("EndX").GlueTo(sh2.CellsSRC(7, 3, 0))
|
||||
|
||||
Case T_LAYOUT_COLUMN_RIGHT
|
||||
Call connector.CellsU("BeginX").GlueTo(sh1.CellsSRC(7, 0, 0))
|
||||
Call connector.CellsU("EndX").GlueTo(sh2.CellsSRC(7, 2, 0))
|
||||
|
||||
Case Else
|
||||
Call connector.CellsU("BeginX").GlueTo(sh1.CellsSRC(7, 2, 0))
|
||||
Call connector.CellsU("EndX").GlueTo(sh2.CellsSRC(7, 2, 0))
|
||||
End Select
|
||||
With connector
|
||||
.CellsSRC(visSectionObject, visRowShapeLayout, visSLORouteStyle).FormulaU = 8
|
||||
.CellsSRC(visSectionObject, visRowShapeLayout, visSLORouteStyle).FormulaU = _
|
||||
prototype.Shapes(1).CellsSRC(visSectionObject, visRowShapeLayout, visSLORouteStyle).FormulaU
|
||||
End With
|
||||
Set CreateConnector = connector
|
||||
End Function
|
||||
|
||||
Public Function ScanExcel(iSource As Excel.Worksheet) As CDS_StaticHierarchy
|
||||
Dim iData As New CDS_StaticHierarchy
|
||||
If iSource.Cells(1, 1) = vbNullString Then _
|
||||
Exit Function
|
||||
|
||||
Dim nRow&
|
||||
For nRow = 1 To iSource.UsedRange.Rows.Count Step 1
|
||||
Dim iNode As CDS_NodeSH: Set iNode = iData.PushItem(iSource.Cells(nRow, 1))
|
||||
If iNode Is Nothing Then _
|
||||
Exit Function
|
||||
Set iNode.data_ = ExrtactXLPayload(iSource, nRow)
|
||||
Call CSE_ProgressBar.IncrementA
|
||||
Next nRow
|
||||
|
||||
Set ScanExcel = iData
|
||||
End Function
|
||||
|
||||
Public Function ScanWord(iSource As Word.Document) As CDS_StaticHierarchy
|
||||
' Scan word file to create DB
|
||||
Dim iData As New CDS_StaticHierarchy
|
||||
Dim iRoot As CDS_NodeSH: Set iRoot = iData.PushItem(1)
|
||||
Set iRoot.data_ = New VisioNode
|
||||
iRoot.data_.text_ = iSource.Name
|
||||
|
||||
Dim aPar As Word.Paragraph
|
||||
Dim pars As Word.Paragraphs: Set pars = iSource.Paragraphs
|
||||
Dim nColor&
|
||||
For Each aPar In pars
|
||||
Dim nRank&: nRank = aPar.OutlineLevel
|
||||
If nRank = wdOutlineLevelBodyText Then _
|
||||
GoTo NEXT_PAR
|
||||
Dim iPayload As VisioNode: Set iPayload = ExtractWordPayload(aPar.Range)
|
||||
If iPayload Is Nothing Then _
|
||||
GoTo NEXT_PAR
|
||||
|
||||
Dim iNode As CDS_NodeSH: Set iNode = iData.PushItem(nRank + 1)
|
||||
If iNode Is Nothing Then _
|
||||
Exit Function
|
||||
Set iNode.data_ = iPayload
|
||||
|
||||
NEXT_PAR:
|
||||
Call CSE_ProgressBar.IncrementA
|
||||
Next aPar
|
||||
|
||||
Set ScanWord = iData
|
||||
End Function
|
||||
|
||||
Public Function ScanVisioNode(iRoot As Visio.Shape, iLayout As TLayout) As CDS_StaticHierarchy
|
||||
Dim iData As New CDS_StaticHierarchy
|
||||
Call ScanShapeRecur(iRoot, iData, iLayout)
|
||||
Set ScanVisioNode = iData
|
||||
End Function
|
||||
|
||||
Public Function Hierarchy2XL(iData As CDS_StaticHierarchy, ByRef iOut As Excel.Worksheet, bFlatData As Boolean)
|
||||
Dim iNode As CDS_NodeSH
|
||||
Dim nRow&: nRow = 1
|
||||
For Each iNode In iData.nodes_
|
||||
If bFlatData Then
|
||||
iOut.Cells(nRow, 1) = iNode.rank_
|
||||
iOut.Cells(nRow, 2) = iNode.data_.text_
|
||||
If iNode.data_.color_ <> COLOR_DEFAULT Then _
|
||||
iOut.Cells(nRow, 2).Interior.Color = iNode.data_.color_
|
||||
Else
|
||||
iOut.Cells(nRow, iNode.rank_) = iNode.data_.text_
|
||||
If iNode.data_.color_ <> COLOR_DEFAULT Then _
|
||||
iOut.Cells(nRow, iNode.rank_).Interior.Color = iNode.data_.color_
|
||||
End If
|
||||
nRow = nRow + 1
|
||||
Next iNode
|
||||
End Function
|
||||
|
||||
Public Function Hierarchy2Word(iData As CDS_StaticHierarchy, ByRef target As Word.Document)
|
||||
If target Is Nothing Then _
|
||||
Exit Function
|
||||
|
||||
Dim iNode As CDS_NodeSH
|
||||
Dim iInsert As Word.Range: Set iInsert = target.Range
|
||||
For Each iNode In iData.nodes_
|
||||
Dim nColor&: nColor = iNode.data_.color_
|
||||
Set iInsert = WordAddLine(iNode.data_.text_, iInsert, WordStyleForRank(target, iNode.rank_))
|
||||
If nColor = COLOR_DEFAULT Then
|
||||
iInsert.Font.Shading.BackgroundPatternColor = wdColorAutomatic
|
||||
Else
|
||||
iInsert.Font.Shading.BackgroundPatternColor = nColor
|
||||
End If
|
||||
Next iNode
|
||||
End Function
|
||||
|
||||
Public Function Hierarchy2WordString(iData As CDS_StaticHierarchy, ByRef target As Word.Document)
|
||||
Const SYMBOL_MASK_TOTAL = "[@#]"
|
||||
Const SYMBOL_MASK_BREAK = "@"
|
||||
|
||||
Dim iStack As New Collection
|
||||
Call iStack.Add(iData.nodes_(1))
|
||||
|
||||
Dim childrenIDs As New Collection
|
||||
Dim curChild&
|
||||
Do While iStack.Count > 0
|
||||
Dim iNode As CDS_NodeSH: Set iNode = iStack.Item(iStack.Count)
|
||||
Dim sLastChar$: sLastChar = IIf(VBA.Len(iNode.data_.text_) > 0, VBA.Right(iNode.data_.text_, 1), "")
|
||||
If sLastChar Like SYMBOL_MASK_TOTAL Or iNode.children_.Count = 0 Then
|
||||
' Terminal
|
||||
Call WordAddLine(StackToString(iStack), target.Range, "Îáû÷íûé")
|
||||
Call iStack.Remove(iStack.Count)
|
||||
Call CSE_ProgressBar.IncrementA
|
||||
If sLastChar Like SYMBOL_MASK_BREAK Then _
|
||||
Exit Do
|
||||
ElseIf childrenIDs.Count < iStack.Count Then
|
||||
' Moving down
|
||||
Call iStack.Add(iNode.children_(1))
|
||||
Call childrenIDs.Add(1)
|
||||
Else
|
||||
curChild = childrenIDs.Item(childrenIDs.Count)
|
||||
If curChild < iNode.children_.Count Then
|
||||
' Move to next child
|
||||
Call childrenIDs.Remove(childrenIDs.Count)
|
||||
Call iStack.Add(iNode.children_(curChild + 1))
|
||||
Call childrenIDs.Add(curChild + 1)
|
||||
Else
|
||||
' Moving up
|
||||
Call childrenIDs.Remove(childrenIDs.Count)
|
||||
Call iStack.Remove(iStack.Count)
|
||||
End If
|
||||
End If
|
||||
Loop
|
||||
End Function
|
||||
|
||||
Public Function GenerateNamesFor(tRoot As Visio.Shape)
|
||||
Dim oldName$: oldName = tRoot.Text
|
||||
If oldName Like "#* *" Then
|
||||
Call NameTheNode(VBA.Left(oldName, VBA.InStr(1, oldName, " ") - 1), tRoot)
|
||||
Else
|
||||
Call NameTheNode("", tRoot)
|
||||
End If
|
||||
End Function
|
||||
|
||||
Public Function TransformNodeLayout(rootShape As Visio.Shape)
|
||||
Dim iData As CDS_StaticHierarchy: Set iData = ScanVisioNode(rootShape, T_LAYOUT_HORIZONTAL)
|
||||
If iData Is Nothing Then
|
||||
Call UserInteraction.ShowMessage(EM_INVALID_STRUCTURE)
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
If Not iData.MaxDepth >= 2 Then
|
||||
Call UserInteraction.ShowMessage(EM_CANNOT_TRANSFORM_DEEP)
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim rootNode As CDS_NodeSH: Set rootNode = iData.nodes_(1)
|
||||
Dim nChildrenCount&: nChildrenCount = rootNode.children_.Count
|
||||
If nChildrenCount < 2 Then _
|
||||
Exit Function
|
||||
|
||||
Dim oChildren As New Collection
|
||||
Dim aNode As CDS_NodeSH
|
||||
For Each aNode In rootNode.children_
|
||||
Call oChildren.Add(aNode.data_.shape_)
|
||||
Next aNode
|
||||
|
||||
Dim theLayout As TLayout: theLayout = T_LAYOUT_HORIZONTAL
|
||||
If oChildren(1).CellsU("PinY") - oChildren(2).CellsU("PinY") < FLOAT_ACCURACY Then _
|
||||
theLayout = T_LAYOUT_VERTICAL
|
||||
|
||||
Call SetLayout(rootShape, oChildren, theLayout)
|
||||
End Function
|
||||
|
||||
Public Function AddNewRankTemplate() As Visio.Master
|
||||
Dim nRank&: nRank = 1
|
||||
Do While Not FindMaster(ThisDocument, MASTER_RANK & nRank) Is Nothing
|
||||
nRank = nRank + 1
|
||||
Loop
|
||||
Dim iMaster As Visio.Master: Set iMaster = ThisDocument.Masters.Add
|
||||
iMaster.Name = MASTER_RANK & nRank
|
||||
Dim iShape As Visio.Shape: Set iShape = iMaster.Drop(GetRankMaster(nRank - 1), 0, 0)
|
||||
iShape.Name = SHAPE_RANK_MASTER & nRank
|
||||
iShape.Text = "Óðîâåíü " & nRank
|
||||
Set AddNewRankTemplate = iMaster
|
||||
End Function
|
||||
|
||||
Public Function ConnectColumns(rootShape As Visio.Shape)
|
||||
Dim iData As CDS_StaticHierarchy: Set iData = ScanVisioNode(rootShape, T_LAYOUT_VERTICAL)
|
||||
If iData Is Nothing Then
|
||||
Call UserInteraction.ShowMessage(EM_INVALID_STRUCTURE)
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim dMidX As Double: dMidX = rootShape.CellsU("PinX")
|
||||
|
||||
Dim iChild As Visio.Shape
|
||||
Dim iConnect As Visio.Connect
|
||||
Dim aNode As CDS_NodeSH
|
||||
For Each aNode In iData.nodes_(1).children_
|
||||
Set iChild = aNode.data_.shape_
|
||||
For Each iConnect In iChild.FromConnects
|
||||
If iConnect.FromSheet.Connects(1).ToSheet Is rootShape Then _
|
||||
Call iConnect.FromSheet.Delete
|
||||
Next iConnect
|
||||
|
||||
If iChild.CellsU("PinX") > dMidX Then
|
||||
Call ConnectNodes(rootShape, iChild, T_LAYOUT_COLUMN_RIGHT)
|
||||
Else
|
||||
Call ConnectNodes(rootShape, iChild, T_LAYOUT_COLUMN_LEFT)
|
||||
End If
|
||||
Next aNode
|
||||
End Function
|
||||
|
||||
' ========
|
||||
Private Function NameTheNode(sID$, target As Visio.Shape)
|
||||
Dim oldName$: oldName = target.Text
|
||||
If VBA.IsNumeric(VBA.Left(oldName, 1)) Then _
|
||||
oldName = VBA.Right(oldName, VBA.Len(oldName) - VBA.InStr(1, oldName, " "))
|
||||
If sID <> vbNullString Then _
|
||||
target.Text = sID & " " & oldName
|
||||
|
||||
Dim oChildren As New Collection: Set oChildren = GetChildrenOf(target)
|
||||
If oChildren.Count = 0 Then _
|
||||
Exit Function
|
||||
|
||||
Dim nIndex() As Long: nIndex = SortChildrenCount(oChildren)
|
||||
|
||||
Dim nItem&: nItem = 1
|
||||
Dim iChild As Visio.Shape
|
||||
For Each iChild In oChildren
|
||||
If sID = vbNullString Then
|
||||
Call NameTheNode(nIndex(nItem) & ".", iChild)
|
||||
Else
|
||||
Call NameTheNode(sID & nIndex(nItem) & ".", iChild)
|
||||
End If
|
||||
nItem = nItem + 1
|
||||
Next iChild
|
||||
End Function
|
||||
|
||||
Private Function SortChildrenCount(oChildren As Collection) As Long()
|
||||
' using CountSort algorithm
|
||||
Dim nIndicies() As Long
|
||||
ReDim nIndicies(1 To oChildren.Count)
|
||||
|
||||
Dim sibling1 As Visio.Shape
|
||||
Dim nItem1&: nItem1 = 1
|
||||
For Each sibling1 In oChildren
|
||||
nIndicies(nItem1) = 1
|
||||
Dim dLeftX As Double: dLeftX = sibling1.CellsU("PinX") - sibling1.CellsU("Width") / 2#
|
||||
Dim dTopY As Double: dTopY = sibling1.CellsU("PinY") + sibling1.CellsU("Height") / 2#
|
||||
|
||||
Dim nItem2&: nItem2 = 1
|
||||
Dim sibling2 As Visio.Shape
|
||||
For Each sibling2 In oChildren
|
||||
If nItem1 = nItem2 Then _
|
||||
GoTo NEXT_2
|
||||
|
||||
Dim dLeftX2 As Double: dLeftX2 = sibling2.CellsU("PinX") - sibling2.CellsU("Width") / 2#
|
||||
Dim dTopY2 As Double: dTopY2 = sibling2.CellsU("PinY") + sibling2.CellsU("Height") / 2#
|
||||
|
||||
If dTopY + FLOAT_ACCURACY < dTopY2 Then
|
||||
nIndicies(nItem1) = nIndicies(nItem1) + 1
|
||||
ElseIf Abs(dTopY - dTopY2) < FLOAT_ACCURACY And dLeftX - FLOAT_ACCURACY > dLeftX2 Then
|
||||
nIndicies(nItem1) = nIndicies(nItem1) + 1
|
||||
End If
|
||||
NEXT_2:
|
||||
nItem2 = nItem2 + 1
|
||||
Next sibling2
|
||||
nItem1 = nItem1 + 1
|
||||
Next sibling1
|
||||
SortChildrenCount = nIndicies
|
||||
End Function
|
||||
|
||||
Public Function SetLayout(theRoot As Visio.Shape, oChildren As Collection, theLayout As TLayout)
|
||||
Dim baseXPos As Double: baseXPos = theRoot.CellsU("PinX")
|
||||
Dim baseYPos As Double: baseYPos = theRoot.CellsU("PinY") - theRoot.CellsU("Height") / 2#
|
||||
|
||||
Dim iChild As Visio.Shape
|
||||
If theLayout = T_LAYOUT_HORIZONTAL Then
|
||||
For Each iChild In oChildren
|
||||
baseXPos = baseXPos - GAP_HORIZONTAL / 2# - iChild.CellsU("Width") / 2#
|
||||
Next iChild
|
||||
End If
|
||||
|
||||
Dim cnt As Visio.Connect
|
||||
For Each iChild In oChildren
|
||||
Dim dWidth As Double: dWidth = iChild.CellsU("Width")
|
||||
Dim dHeight As Double: dHeight = iChild.CellsU("Height")
|
||||
For Each cnt In iChild.FromConnects
|
||||
If cnt.FromSheet.Connects(1).ToSheet Is theRoot Then _
|
||||
Call cnt.FromSheet.Delete
|
||||
Next cnt
|
||||
|
||||
iChild.CellsU("PinY") = baseYPos - GAP_VERTICAL - dHeight / 2#
|
||||
If theLayout = T_LAYOUT_VERTICAL Then
|
||||
iChild.CellsU("PinX") = baseXPos - theRoot.CellsU("Width") / 2# + dWidth / 2#
|
||||
baseYPos = baseYPos - GAP_VERTICAL - dHeight
|
||||
Else
|
||||
iChild.CellsU("PinX") = baseXPos + GAP_HORIZONTAL + dWidth / 2#
|
||||
baseXPos = baseXPos + GAP_HORIZONTAL + dWidth
|
||||
End If
|
||||
|
||||
Call ConnectNodes(theRoot, iChild, theLayout)
|
||||
Next iChild
|
||||
End Function
|
||||
|
||||
Private Function ScanShapeRecur(target As Visio.Shape, ByRef iData As CDS_StaticHierarchy, _
|
||||
aLayout As TLayout, Optional iParent As CDS_NodeSH = Nothing)
|
||||
If target Is Nothing Then _
|
||||
Exit Function
|
||||
Dim nRank&: nRank = 1
|
||||
If Not iParent Is Nothing Then _
|
||||
nRank = iParent.rank_ + 1
|
||||
|
||||
Dim iNode As CDS_NodeSH: Set iNode = iData.PushItem(nRank)
|
||||
Set iNode.data_ = ExtractVsoPayload(target)
|
||||
|
||||
Dim oChildren As Collection: Set oChildren = GetChildrenOf(target)
|
||||
If oChildren.Count = 0 Then _
|
||||
Exit Function
|
||||
|
||||
Dim nIndicies() As Long: nIndicies = SortChildrenLayout(oChildren, target, aLayout)
|
||||
Dim n&
|
||||
For n = 1 To oChildren.Count
|
||||
Call ScanShapeRecur(oChildren(nIndicies(n)), iData, aLayout, iNode)
|
||||
Next n
|
||||
End Function
|
||||
|
||||
Private Function SortChildrenLayout(oChildren As Collection, aParent As Visio.Shape, iLayout As TLayout) As Long()
|
||||
' using bubble sort algorithm
|
||||
Dim nCount&: nCount = oChildren.Count
|
||||
Dim nIndicies() As Long
|
||||
ReDim nIndicies(1 To nCount)
|
||||
Dim n&
|
||||
For n = 1 To nCount Step 1
|
||||
nIndicies(n) = n
|
||||
Next n
|
||||
If nCount = 1 Then
|
||||
SortChildrenLayout = nIndicies
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim k&
|
||||
For n = 1 To nCount - 1 Step 1
|
||||
For k = n + 1 To nCount
|
||||
If CompareChildren(aParent, oChildren(nIndicies(n)), oChildren(nIndicies(k)), iLayout) Then
|
||||
nIndicies(n) = nIndicies(n) + nIndicies(k)
|
||||
nIndicies(k) = nIndicies(n) - nIndicies(k)
|
||||
nIndicies(n) = nIndicies(n) - nIndicies(k)
|
||||
End If
|
||||
Next k
|
||||
Next n
|
||||
SortChildrenLayout = nIndicies
|
||||
End Function
|
||||
|
||||
Private Function CompareChildren(aParent As Visio.Shape, child1 As Visio.Shape, child2 As Visio.Shape, iLayout As TLayout) As Boolean
|
||||
Select Case iLayout
|
||||
Case T_LAYOUT_RADIAL
|
||||
CompareChildren = _
|
||||
aParent.DistanceFrom(child1, visSpatialIncludeDataGraphics) _
|
||||
- aParent.DistanceFrom(child2, visSpatialIncludeDataGraphics) _
|
||||
> FLOAT_ACCURACY
|
||||
Case T_LAYOUT_HORIZONTAL
|
||||
CompareChildren = child1.CellsU("PinX") - child2.CellsU("PinX") > FLOAT_ACCURACY
|
||||
Case T_LAYOUT_VERTICAL
|
||||
CompareChildren = child2.CellsU("PinY") - child1.CellsU("PinY") > FLOAT_ACCURACY
|
||||
End Select
|
||||
End Function
|
||||
|
||||
Private Function StackToString(iStack As Collection) As String
|
||||
Dim theString$: theString = ""
|
||||
Dim bFirst As Boolean: bFirst = True
|
||||
Dim iNode As CDS_NodeSH
|
||||
For Each iNode In iStack
|
||||
If Not bFirst Then _
|
||||
theString = theString & " "
|
||||
bFirst = False
|
||||
theString = theString & iNode.data_.text_
|
||||
Next iNode
|
||||
StackToString = theString
|
||||
End Function
|
||||
|
||||
123
src/MasterDlg.frm
Normal file
123
src/MasterDlg.frm
Normal file
|
|
@ -0,0 +1,123 @@
|
|||
VERSION 5.00
|
||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} MasterDlg
|
||||
ClientHeight = 5925
|
||||
ClientLeft = 120
|
||||
ClientTop = 465
|
||||
ClientWidth = 5250
|
||||
OleObjectBlob = "MasterDlg.frx":0000
|
||||
StartUpPosition = 1 'CenterOwner
|
||||
End
|
||||
Attribute VB_Name = "MasterDlg"
|
||||
Attribute VB_GlobalNameSpace = False
|
||||
Attribute VB_Creatable = False
|
||||
Attribute VB_PredeclaredId = True
|
||||
Attribute VB_Exposed = False
|
||||
Option Explicit
|
||||
|
||||
Public bCanceled As Boolean
|
||||
|
||||
Private Sub UserForm_Initialize()
|
||||
bCanceled = True
|
||||
Me.StartUpPosition = visCenter
|
||||
UpdateState
|
||||
End Sub
|
||||
|
||||
Public Property Get InputMode() As IOMode
|
||||
' Get Input mode
|
||||
InputMode = MODE_EXCEL
|
||||
If btnInputOpt1.Value = True Then InputMode = MODE_WORD
|
||||
If btnInputOpt3.Value = True Then InputMode = MODE_VISIO
|
||||
End Property
|
||||
|
||||
Public Property Get OutputMode() As IOMode
|
||||
' Get output mode
|
||||
OutputMode = MODE_EXCEL
|
||||
If btnOutputOpt1.Value = True Then OutputMode = MODE_WORD
|
||||
If btnOutputOpt3.Value = True Then OutputMode = MODE_VISIO
|
||||
End Property
|
||||
|
||||
Public Property Get InputLayout() As TLayout
|
||||
InputLayout = T_LAYOUT_RADIAL
|
||||
If btnModeX.Value = True Then InputLayout = T_LAYOUT_HORIZONTAL
|
||||
If btnModeY.Value = True Then InputLayout = T_LAYOUT_VERTICAL
|
||||
End Property
|
||||
|
||||
Public Property Get AutoLayout() As Boolean
|
||||
AutoLayout = CheckBox1.Value
|
||||
End Property
|
||||
|
||||
Public Property Get WordExportAsString() As Boolean
|
||||
WordExportAsString = CheckBox2.Value
|
||||
End Property
|
||||
|
||||
Public Property Get XLExportAsTree() As Boolean
|
||||
XLExportAsTree = CBExcel.Value
|
||||
End Property
|
||||
|
||||
Public Property Get InputFile() As String
|
||||
InputFile = textInput.Text
|
||||
End Property
|
||||
|
||||
Private Sub btnInput_Click()
|
||||
If InputMode = MODE_VISIO Then
|
||||
Call UserInteraction.ShowMessage(EM_VISIO_INPUT)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim sFile$: sFile = UserInteraction.PromptFile(ActiveDocument.Path, "Âûáåðèòå âõîäíîé ôàéë", bNewApplication:=True)
|
||||
If sFile = vbNullString Then _
|
||||
Exit Sub
|
||||
|
||||
textInput.Text = sFile
|
||||
End Sub
|
||||
|
||||
Private Sub btnInputOpt1_Click()
|
||||
UpdateState
|
||||
End Sub
|
||||
|
||||
Private Sub btnInputOpt2_Click()
|
||||
UpdateState
|
||||
End Sub
|
||||
|
||||
Private Sub btnInputOpt3_Click()
|
||||
UpdateState
|
||||
End Sub
|
||||
|
||||
Private Sub btnOutputOpt1_Click()
|
||||
UpdateState
|
||||
End Sub
|
||||
|
||||
Private Sub btnOutputOpt2_Click()
|
||||
UpdateState
|
||||
End Sub
|
||||
|
||||
Private Sub btnOutputOpt3_Click()
|
||||
UpdateState
|
||||
End Sub
|
||||
|
||||
Private Function UpdateState()
|
||||
CheckBox2.Visible = btnOutputOpt1.Value
|
||||
CheckBox1.Visible = btnOutputOpt3.Value
|
||||
CBExcel.Visible = btnOutputOpt2.Value
|
||||
|
||||
lblLevel.Visible = btnInputOpt3.Value
|
||||
btnModeX.Visible = btnInputOpt3.Value
|
||||
btnModeY.Visible = btnInputOpt3.Value
|
||||
btnModeRad.Visible = btnInputOpt3.Value
|
||||
End Function
|
||||
|
||||
Private Sub UserForm_Activate()
|
||||
bCanceled = True
|
||||
End Sub
|
||||
|
||||
Private Sub OkBtn_Click()
|
||||
bCanceled = False
|
||||
Me.Hide
|
||||
End Sub
|
||||
|
||||
Private Sub CancelBtn_Click()
|
||||
bCanceled = True
|
||||
Me.Hide
|
||||
End Sub
|
||||
|
||||
|
||||
BIN
src/MasterDlg.frx
Normal file
BIN
src/MasterDlg.frx
Normal file
Binary file not shown.
22
src/ThisDocument.cls
Normal file
22
src/ThisDocument.cls
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
VERSION 1.0 CLASS
|
||||
BEGIN
|
||||
MultiUse = -1 'True
|
||||
END
|
||||
Attribute VB_Name = "ThisDocument"
|
||||
Attribute VB_GlobalNameSpace = False
|
||||
Attribute VB_Creatable = False
|
||||
Attribute VB_PredeclaredId = True
|
||||
Attribute VB_Exposed = True
|
||||
Option Explicit
|
||||
|
||||
Private Sub Document_DocumentOpened(ByVal iDoc As IVDocument)
|
||||
If iDoc.ID <> ThisDocument.ID Then _
|
||||
Exit Sub
|
||||
|
||||
Dim sCmd$: sCmd = OfficeCommandLine
|
||||
If VBA.InStr(1, sCmd, "/automation", vbTextCompare) <> 0 Then _
|
||||
Exit Sub
|
||||
|
||||
Call StartVersionCheck
|
||||
End Sub
|
||||
|
||||
20
src/VisioNode.cls
Normal file
20
src/VisioNode.cls
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
VERSION 1.0 CLASS
|
||||
BEGIN
|
||||
MultiUse = -1 'True
|
||||
END
|
||||
Attribute VB_Name = "VisioNode"
|
||||
Attribute VB_GlobalNameSpace = False
|
||||
Attribute VB_Creatable = False
|
||||
Attribute VB_PredeclaredId = False
|
||||
Attribute VB_Exposed = False
|
||||
'------------ Visio hierarchy node ---------------
|
||||
Option Explicit
|
||||
|
||||
Public text_ As String
|
||||
Public color_ As Long
|
||||
|
||||
Public shape_ As Visio.Shape
|
||||
|
||||
Private Sub Class_Initialize()
|
||||
color_ = COLOR_DEFAULT
|
||||
End Sub
|
||||
94
src/z_UIMessages.bas
Normal file
94
src/z_UIMessages.bas
Normal file
|
|
@ -0,0 +1,94 @@
|
|||
Attribute VB_Name = "z_UIMessages"
|
||||
' Messaging module
|
||||
Option Private Module
|
||||
Option Explicit
|
||||
|
||||
Public Enum MsgCode
|
||||
MSG_OK = 0
|
||||
|
||||
EM_VISIO_INPUT
|
||||
EM_FILENAME_EMPTY
|
||||
EM_INVALID_SELECTION
|
||||
EM_ERROR_LOADING_FILE
|
||||
EM_INVALID_FILE_FORMAT
|
||||
EM_WORD_MAX_LEVELS
|
||||
EM_INVALID_STRUCTURE
|
||||
EM_CANNOT_TRANSFORM_DEEP
|
||||
EM_INVALID_FORMAT
|
||||
|
||||
IM_EXPORT_OK
|
||||
IM_IMPORT_OK
|
||||
IM_NEW_TEMPLATE
|
||||
|
||||
' QM_CODE_DELETE_CONFIRM
|
||||
End Enum
|
||||
|
||||
Private g_UI As API_UserInteraction
|
||||
|
||||
Public Function UserInteraction() As API_UserInteraction
|
||||
If g_UI Is Nothing Then _
|
||||
Set g_UI = New API_UserInteraction
|
||||
Set UserInteraction = g_UI
|
||||
End Function
|
||||
|
||||
Public Function SetUserInteraction(newUI As API_UserInteraction)
|
||||
Set g_UI = newUI
|
||||
End Function
|
||||
|
||||
Public Function UIShowMessage(theCode As MsgCode, ParamArray params() As Variant)
|
||||
Dim unwrapped As Variant: unwrapped = params
|
||||
unwrapped = FixForwardedParams(unwrapped)
|
||||
|
||||
Select Case theCode
|
||||
Case EM_VISIO_INPUT
|
||||
Call MsgBox("Ðåæèì ââîäà èç Visio íå òðåáóåò óêàçàíèÿ âõîäà", vbInformation)
|
||||
Case EM_FILENAME_EMPTY
|
||||
Call MsgBox("Íå óêàçàí ïóòü ê âõîäíîìó ôàéëó", vbExclamation)
|
||||
Case EM_INVALID_SELECTION
|
||||
Call MsgBox("Äëÿ äàííîé îïåðàöèè íåîáõîäèìî âûäåëèòü îäíó êîðíåâóþ ôîðìó", vbExclamation)
|
||||
Case EM_ERROR_LOADING_FILE
|
||||
Call MsgBox("Îøèáêà ïðè çàãðóçêå ôàéëà", vbExclamation)
|
||||
Case EM_INVALID_FILE_FORMAT
|
||||
Call MsgBox("Îøèáêà ïðè çàãðóçêå äàííûõ!" & vbNewLine & _
|
||||
"Ïðîâåðüòå ñîîòâåòñòâèå âõîäà çàäàííîìó ôîðìàòó", vbExclamation)
|
||||
Case EM_WORD_MAX_LEVELS
|
||||
Call MsgBox("Ýêñïîðò â Word âîçìîæåí òîëüêî äëÿ 9 è ìåíåå óðîâíåé!", vbCritical)
|
||||
Case EM_INVALID_STRUCTURE
|
||||
Call MsgBox("Íåêîððåêòíàÿ ñòðóêòóðà èåðàðõèè", vbCritical)
|
||||
Case EM_CANNOT_TRANSFORM_DEEP
|
||||
Call MsgBox("Òðàíñôîðìèðîâàòü ìîæíî òîëüêî óçëû íå èìåþùèå ""âíóêîâ""", vbCritical)
|
||||
Case EM_INVALID_FORMAT
|
||||
Call MsgBox(Fmt("Ñîäåðæèìîå ôàéëà {1} íå ñîîòâåòñòâóåò òðåáóåìîìó ôîðìàòó", unwrapped), vbExclamation)
|
||||
|
||||
Case IM_EXPORT_OK
|
||||
Call MsgBox(Fmt("Ýêñïîðò ïðîøåë óñïåøíî!" & vbNewLine & _
|
||||
"Âñåãî óçëîâ: {1}" & vbNewLine & _
|
||||
"Ìàêñèìàëüíàÿ ãëóáèíà: {2}", unwrapped), vbInformation)
|
||||
Case IM_IMPORT_OK
|
||||
Call MsgBox(Fmt("Èìïîðò äàííûõ ïðîøåë óñïåøíî!" & vbNewLine & _
|
||||
"Âñåãî óçëîâ: {1}" & vbNewLine & _
|
||||
"Ìàêñèìàëüíàÿ ãëóáèíà: {2}" & vbNewLine & _
|
||||
"Ðàçìåð ëèñòà: {3} x {4}", unwrapped), vbInformation)
|
||||
Case IM_NEW_TEMPLATE
|
||||
Call MsgBox(Fmt("Íîâûå øàáëîí ñîçäàí óñïåøíî: {1}", unwrapped), vbInformation)
|
||||
|
||||
|
||||
Case Else
|
||||
Call MsgBox("Invalid message code", vbCritical)
|
||||
End Select
|
||||
End Function
|
||||
|
||||
Public Function UIAskQuestion(theCode As MsgCode, ParamArray params() As Variant) As Boolean
|
||||
Dim unwrapped As Variant: unwrapped = params
|
||||
unwrapped = FixForwardedParams(unwrapped)
|
||||
|
||||
Dim answer&: answer = vbNo
|
||||
Select Case theCode
|
||||
' Case QM_CODE_DELETE_CONFIRM
|
||||
' answer = MsgBox("Are you sure you want to delete ALL macros from target file?", vbYesNo + vbQuestion)
|
||||
|
||||
Case Else
|
||||
Call MsgBox("Invalid message code", vbCritical)
|
||||
End Select
|
||||
UIAskQuestion = answer = vbYes
|
||||
End Function
|
||||
20
src/z_UIRibbon.bas
Normal file
20
src/z_UIRibbon.bas
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
Attribute VB_Name = "z_UIRibbon"
|
||||
Option Explicit
|
||||
|
||||
Public Sub OnAction(iControl As IRibbonControl)
|
||||
Select Case iControl.ID
|
||||
Case "LoadExcel": Call RunImportXL
|
||||
Case "LoadWord": Call RunImportWord
|
||||
Case "Clear": Call RunClearScheme
|
||||
Case "MasterIO": Call RunMaster
|
||||
|
||||
Case "Transform": Call RunTransform
|
||||
Case "ConnectColumns": Call RunConnectColumns
|
||||
Case "AutoName": Call RunRename
|
||||
|
||||
Case "ContextTransform": Call RunTransform
|
||||
Case "NewRankTemplate": Call RunNewRankTemplate
|
||||
|
||||
Case Else: Call CC_DispatchCommand(iControl.ID)
|
||||
End Select
|
||||
End Sub
|
||||
2
ui/.rels
Normal file
2
ui/.rels
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
|
||||
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships"><Relationship Id="rId3" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Target="docProps/core.xml"/><Relationship Id="rId2" Type="http://schemas.microsoft.com/office/2007/relationships/ui/extensibility" Target="visio/customUI/customUI1.xml"/><Relationship Id="rId1" Type="http://schemas.microsoft.com/visio/2010/relationships/document" Target="visio/document.xml"/><Relationship Id="rId5" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties" Target="docProps/custom.xml"/><Relationship Id="rId4" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Target="docProps/app.xml"/></Relationships>
|
||||
90
ui/customUI1.xml
Normal file
90
ui/customUI1.xml
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
<?xml version="1.0" encoding="utf-8"?>
|
||||
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
|
||||
<ribbon>
|
||||
<tabs>
|
||||
<tab id="tab1" label="ИЕРАРХИЗАТОР">
|
||||
<group id="IO" label="Загрузка/очистка иерархии">
|
||||
<button id="LoadExcel" size="large"
|
||||
label="Excel"
|
||||
supertip="Загрузка иерархии из Excel"
|
||||
imageMso="FileSaveAsExcelXlsx"
|
||||
onAction="OnAction"/>
|
||||
<button id="LoadWord" size="large"
|
||||
label="Word"
|
||||
supertip="Загрузка иерархии из Word"
|
||||
imageMso="FileSaveAsWordDocx"
|
||||
onAction="OnAction"/>
|
||||
<button id="MasterIO" size="large"
|
||||
label="Мастер"
|
||||
supertip="Мастер преобразоваия форматов"
|
||||
imageMso="QueryBuilder"
|
||||
onAction="OnAction"/>
|
||||
</group>
|
||||
|
||||
<group id="Navigation" label="Навигация">
|
||||
<button id="ExpandStraight" size="large"
|
||||
label="Потомки"
|
||||
supertip="Добавить в выделение всех потомков"
|
||||
imageMso="DiagramExpandClassic"
|
||||
onAction="OnAction"/>
|
||||
<button id="ExpandReverse" size="large"
|
||||
label="Предки"
|
||||
supertip="Добавить в выделение всех предков"
|
||||
imageMso="DiagramFitToContentsClassic"
|
||||
onAction="OnAction"/>
|
||||
<button id="GotoLinkBegin"
|
||||
label="В начало"
|
||||
supertip="Переход к началу выделенной стрелки [Ctrl+Shift+Q]"
|
||||
imageMso="JotNavUIFindRTL"
|
||||
onAction="OnAction"/>
|
||||
<button id="GotoLinkEnd"
|
||||
label="В конец"
|
||||
supertip="Переход к концу выделенной стрелки [Ctrl+Shift+E]"
|
||||
imageMso="JotNavUIFind"
|
||||
onAction="OnAction"/>
|
||||
</group>
|
||||
|
||||
<group id="Actions" label="Операции">
|
||||
<button id="Transform"
|
||||
label="Трансформация"
|
||||
supertip="Преобразование подуровня для выделенного узла в вертикальный / горизонтальный вид (CTRL+SHIFT+Z)"
|
||||
imageMso="CircularReferences"
|
||||
onAction="OnAction"/>
|
||||
<button id="ConnectColumns"
|
||||
label="Из центра"
|
||||
supertip="Привязать коннекторы потомков к центру нижней границы"
|
||||
imageMso="ArrowsMore"
|
||||
onAction="OnAction"/>
|
||||
<button id="AutoName"
|
||||
label="Автонумерация"
|
||||
supertip="Нумерация узлов поддерева согласно уровням иерархии"
|
||||
imageMso="ConstrainNumeric"
|
||||
onAction="OnAction"/>
|
||||
|
||||
<button id="Clear"
|
||||
label="Очистка"
|
||||
supertip="Очистка иерархии (CTRL+SHIFT+X)"
|
||||
size="large"
|
||||
imageMso="TableDeleteRowsAndColumnsMenuWord"
|
||||
onAction="OnAction"/>
|
||||
<button id="NewRankTemplate"
|
||||
label="Новый шаблон"
|
||||
supertip="Добавить шаблон для следующего уровня"
|
||||
size="large"
|
||||
imageMso="ChartSaveTemplates"
|
||||
onAction="OnAction"/>
|
||||
</group>
|
||||
</tab>
|
||||
</tabs>
|
||||
</ribbon>
|
||||
|
||||
<contextMenus>
|
||||
<contextMenu idMso="ContextMenuShape">
|
||||
<button id="ContextTransform"
|
||||
label="Трансформация"
|
||||
supertip="Преобразование подуровня для выделенного узла в вертикальный / горизонтальный вид"
|
||||
imageMso="CircularReferences"
|
||||
onAction="OnAction"/>
|
||||
</contextMenu>
|
||||
</contextMenus>
|
||||
</customUI>
|
||||
Loading…
Reference in New Issue
Block a user