commit 306e18c4f8f426ca3f94e2e93002d8c41905fdd0 Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:06:17 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..88eecae --- /dev/null +++ b/VBAMake.txt @@ -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 \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..26aaba0 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +1.2.0 diff --git a/distr/!Readme.docx b/distr/!Readme.docx new file mode 100644 index 0000000..763ff4c Binary files /dev/null and b/distr/!Readme.docx differ diff --git a/distr/Пример входных данных.xlsx b/distr/Пример входных данных.xlsx new file mode 100644 index 0000000..3e1cc70 Binary files /dev/null and b/distr/Пример входных данных.xlsx differ diff --git a/script/manifest.txt b/script/manifest.txt new file mode 100644 index 0000000..b46ae18 --- /dev/null +++ b/script/manifest.txt @@ -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 \ No newline at end of file diff --git a/skeleton/Иерархизатор.vsdm b/skeleton/Иерархизатор.vsdm new file mode 100644 index 0000000..f2843de Binary files /dev/null and b/skeleton/Иерархизатор.vsdm differ diff --git a/src/DataAccess.bas b/src/DataAccess.bas new file mode 100644 index 0000000..a976024 --- /dev/null +++ b/src/DataAccess.bas @@ -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 + diff --git a/src/Declarations.bas b/src/Declarations.bas new file mode 100644 index 0000000..da5623a --- /dev/null +++ b/src/Declarations.bas @@ -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" diff --git a/src/DevHelper.bas b/src/DevHelper.bas new file mode 100644 index 0000000..d5b4a6e --- /dev/null +++ b/src/DevHelper.bas @@ -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 diff --git a/src/LayoutConstruction.cls b/src/LayoutConstruction.cls new file mode 100644 index 0000000..458cf1a --- /dev/null +++ b/src/LayoutConstruction.cls @@ -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 diff --git a/src/Main.bas b/src/Main.bas new file mode 100644 index 0000000..f9df025 --- /dev/null +++ b/src/Main.bas @@ -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 diff --git a/src/MainImpl.bas b/src/MainImpl.bas new file mode 100644 index 0000000..6e0f348 --- /dev/null +++ b/src/MainImpl.bas @@ -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 + diff --git a/src/MasterDlg.frm b/src/MasterDlg.frm new file mode 100644 index 0000000..a11b135 --- /dev/null +++ b/src/MasterDlg.frm @@ -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 + + diff --git a/src/MasterDlg.frx b/src/MasterDlg.frx new file mode 100644 index 0000000..41dbd83 Binary files /dev/null and b/src/MasterDlg.frx differ diff --git a/src/ThisDocument.cls b/src/ThisDocument.cls new file mode 100644 index 0000000..8d5a8b6 --- /dev/null +++ b/src/ThisDocument.cls @@ -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 + diff --git a/src/VisioNode.cls b/src/VisioNode.cls new file mode 100644 index 0000000..974adda --- /dev/null +++ b/src/VisioNode.cls @@ -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 diff --git a/src/z_UIMessages.bas b/src/z_UIMessages.bas new file mode 100644 index 0000000..7494436 --- /dev/null +++ b/src/z_UIMessages.bas @@ -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 diff --git a/src/z_UIRibbon.bas b/src/z_UIRibbon.bas new file mode 100644 index 0000000..1f5550d --- /dev/null +++ b/src/z_UIRibbon.bas @@ -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 diff --git a/ui/.rels b/ui/.rels new file mode 100644 index 0000000..5ecfe27 --- /dev/null +++ b/ui/.rels @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/ui/customUI1.xml b/ui/customUI1.xml new file mode 100644 index 0000000..6c77c6e --- /dev/null +++ b/ui/customUI1.xml @@ -0,0 +1,90 @@ + + + + + + +