commit f33a2c1ceb9eda7eadd97e5251cc65ac4a55372e Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:02:35 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..959b0c5 --- /dev/null +++ b/VBAMake.txt @@ -0,0 +1,43 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home + +id = Concept-Blocks +name = Концепт-Блоки +description = Технология визуализации отношений КС в различных формах +artifact_home = Концепт-Блоки +source_home = Concept-Blocks +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 + +copy distr\!Руководство пользователя.docx +copy distr\Шаблоны\Блоки-Excel.xltx -> Шаблоны\Блоки-Excel.xltx +copy distr\Шаблоны\Блоки-Word.dotx -> Шаблоны\Блоки-Word.dotx + +%% +# === Install section == +# Available commands: +# install LOCAL_ARTIFACT -> [INSTALL_PATH] +# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE] +# run LOCAL_ARTIFACT.bat <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + +install Блоки.vstm + +install !Руководство пользователя.docx +install Шаблоны\Блоки-Excel.xltx -> Шаблоны\Блоки-Excel.xltx +install Шаблоны\Блоки-Word.dotx -> Шаблоны\Блоки-Word.dotx + +add_template Блоки.vstm -> 20 Концепт-Блоки.vstm +add_template Шаблоны\Блоки-Excel.xltx -> Технологии\Блоки-Excel.xltx +add_template Шаблоны\Блоки-Word.dotx -> Технологии\Блоки-Word.dotx \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..f0bb29e --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +1.3.0 diff --git a/distr/!Руководство пользователя.docx b/distr/!Руководство пользователя.docx new file mode 100644 index 0000000..c92b61f Binary files /dev/null and b/distr/!Руководство пользователя.docx differ diff --git a/distr/Шаблоны/Блоки-Excel.xltx b/distr/Шаблоны/Блоки-Excel.xltx new file mode 100644 index 0000000..9c84b94 Binary files /dev/null and b/distr/Шаблоны/Блоки-Excel.xltx differ diff --git a/distr/Шаблоны/Блоки-Word.dotx b/distr/Шаблоны/Блоки-Word.dotx new file mode 100644 index 0000000..ed99c69 Binary files /dev/null and b/distr/Шаблоны/Блоки-Word.dotx differ diff --git a/script/manifest.txt b/script/manifest.txt new file mode 100644 index 0000000..f1dd22a --- /dev/null +++ b/script/manifest.txt @@ -0,0 +1,94 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = Блоки.vstm +artifact = Блоки.vstm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +ui + CSE_ProgressBar.frm + +api + ex_WinAPI.bas + API_VsoWrapper.cls + API_XLWrapper.cls + API_WordWrapper.cls + API_UserInteraction.cls + +utility + ex_VBA.bas + ex_Collection.bas + ex_Version.bas + + API_DistrManifest.cls + API_JSON.cls + API_LinkedComponents.cls + API_GraphOrdering.cls + CDS_Edge.cls + CDS_Factorizator.cls + CDS_Graph.cls + CDS_Node.cls + +visio + z_VsoUtilities.bas + z_CCVsoExtension.bas + z_VsoGraph.bas + API_UndoWrapper.cls + +word + ex_Word.bas + +dev + DevTester.bas + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + DevHelper.bas + Declarations.bas + DataAccess.bas + Main.bas + MainImpl.bas + z_UIRibbon.bas + z_UIMessages.bas + + PowerEstimator.cls + WordExporter.cls + XLExporter.cls + + s_ContextActions.cls + s_Operations.cls + s_DataAccess.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 : Scripting +global : Excel +global : Word +global : MSForms +global : Shell32 \ No newline at end of file diff --git a/skeleton/Блоки.vstm b/skeleton/Блоки.vstm new file mode 100644 index 0000000..f903405 Binary files /dev/null and b/skeleton/Блоки.vstm differ diff --git a/src/DataAccess.bas b/src/DataAccess.bas new file mode 100644 index 0000000..25e3827 --- /dev/null +++ b/src/DataAccess.bas @@ -0,0 +1,173 @@ +Attribute VB_Name = "DataAccess" +Option Private Module +Option Explicit + +Public Function ExtractGraphNodes(target As Visio.Page) As Collection + Dim iNodes As New Collection + Dim aShape As Visio.Shape + For Each aShape In target.Shapes + If aShape.OneD Or aShape.MasterShape Is Nothing Then _ + GoTo NEXT_SHAPE + Dim sMaster$: sMaster = aShape.MasterShape.Name + If sMaster = SHAPE_OPERATION _ + Or sMaster = SHAPE_SCHEMA _ + Or sMaster = SHAPE_PROXY Then _ + Call iNodes.Add(aShape) +NEXT_SHAPE: + Next aShape + Set ExtractGraphNodes = iNodes +End Function + +Public Function ExtractSchemas(target As Visio.Page) As Collection + Dim iSchemas As New Collection + Dim aShape As Visio.Shape + For Each aShape In target.Shapes + If aShape.OneD Or aShape.MasterShape Is Nothing Then _ + GoTo NEXT_SHAPE + Dim sMaster$: sMaster = aShape.MasterShape.Name + If sMaster = SHAPE_SCHEMA Then _ + Call iSchemas.Add(aShape) +NEXT_SHAPE: + Next aShape + Set ExtractSchemas = iSchemas +End Function + +Public Function GetTemplate(sFile$, sLocalFolder$) As String + Dim fso As New Scripting.FileSystemObject + + GetTemplate = SERVER_TEMPLATES & "\" & sFile + If fso.FileExists(GetTemplate) Then _ + Exit Function + + GetTemplate = sLocalFolder & "\" & sFile + If fso.FileExists(GetTemplate) Then _ + Exit Function + + GetTemplate = TEMPLATE_PREFIX & "\" & sFile +End Function + +Public Function TrimEnumerator(sText$) As String + If IsNumerated(sText) Then + Dim pos&: pos = VBA.InStr(1, sText, " ") + TrimEnumerator = VBA.Right(sText, VBA.Len(sText) - pos) + Else + TrimEnumerator = sText + End If +End Function + +Public Function ExtractEnumerator(sText$) As Long + If Not IsNumerated(sText) Then _ + Exit Function + If sText Like "[?][?][?] *" Then _ + Exit Function + Dim nPos&: nPos = VBA.InStr(1, sText, " ") + If VBA.Left(sText, 1) = "!" Then + ExtractEnumerator = CLng(VBA.Mid(sText, 4, nPos - 4)) + Else + ExtractEnumerator = CLng(VBA.Mid(sText, 3, nPos - 3)) + End If +End Function + +Public Function AppendEnumerator(sText$, nIndex&) As String + AppendEnumerator = "" + Format(nIndex, "00") + " " + sText +End Function + +Public Function IsElementary(shapeType As TElement) As Boolean + Select Case (shapeType) + Case T_EL_UNKNOWN: IsElementary = False + Case T_EL_SCHEMA: IsElementary = False + Case T_EL_PROXY: IsElementary = False + Case T_EL_BLOCK: IsElementary = False + Case T_EL_OPERATION: IsElementary = False + Case T_EL_HEADER: IsElementary = False + Case T_EL_MINIATURE: IsElementary = False + Case Else: IsElementary = True + End Select +End Function + +Public Function GetShapeType(target As Visio.Shape) As TElement + If target.MasterShape Is Nothing Then + GetShapeType = T_EL_UNKNOWN + Exit Function + End If + + Select Case (target.MasterShape.Name) + Case SHAPE_SCHEMA: GetShapeType = T_EL_SCHEMA + Case SHAPE_PROXY: GetShapeType = T_EL_PROXY + Case SHAPE_BLOCK: GetShapeType = T_EL_BLOCK + Case SHAPE_OPERATION: GetShapeType = T_EL_OPERATION + Case SHAPE_IDENTIFICATION: GetShapeType = T_EL_IDENTITY + Case SHAPE_ELEMENT: GetShapeType = GetElementaryType(target) + Case SHAPE_HEADER: GetShapeType = T_EL_HEADER + Case SHAPE_MINIATURE: GetShapeType = T_EL_MINIATURE + Case Else: GetShapeType = T_EL_UNKNOWN + End Select +End Function + +Public Function GetElementaryType(target As Visio.Shape) As TElement + If Not target.CellExistsU(CELLSU_ELEMENT_TYPE, visExistsAnywhere) Then + GetElementaryType = T_EL_COMMENT + Exit Function + End If + + Select Case (target.CellsU(CELLSU_ELEMENT_TYPE)) + Case T_SE_BASIC: GetElementaryType = T_EL_BASIC + Case T_SE_DERIVED: GetElementaryType = T_EL_DERIVED + Case T_SE_ASSERTION: GetElementaryType = T_EL_ASSERTION + Case T_SE_COMMENT: GetElementaryType = T_EL_COMMENT + Case T_SE_INTERPRETATION: GetElementaryType = T_EL_INTERPRETATION + Case Else: GetElementaryType = T_EL_BASIC + End Select +End Function + +Public Function ExtractPowerLevels(target As Visio.Page) As Scripting.Dictionary + Dim iGraph As CDS_Graph: Set iGraph = ScanGraph(ExtractGraphNodes(target), False) + Dim iOrder As Collection: Set iOrder = GeotopSort(target, iGraph) + Dim iReps As Scripting.Dictionary: Set iReps = ExtractRepresentatives(target) + Dim estimator As New PowerEstimator + Set ExtractPowerLevels = estimator.Estimate(iGraph, iOrder, iReps) +End Function + +Public Function ExtractRepresentatives(target As Visio.Page) As Scripting.Dictionary + Dim iReps As New Scripting.Dictionary + + Dim schemas As Collection: Set schemas = ExtractGraphNodes(target) + Dim textReps As New Scripting.Dictionary + Dim aShape As Visio.Shape + Dim sText$ + For Each aShape In schemas + If aShape.MasterShape.Name = SHAPE_SCHEMA Then + sText = TrimEnumerator(aShape.Text) + If Not textReps.Exists(sText) Then _ + Call textReps.Add(sText, aShape.ID) + End If + Next aShape + + For Each aShape In schemas + If aShape.MasterShape.Name = SHAPE_PROXY Then + sText = TrimEnumerator(aShape.Text) + If textReps.Exists(sText) Then _ + Call iReps.Add(aShape.ID, textReps(sText)) + End If + Next aShape + + Set ExtractRepresentatives = iReps +End Function + +' ========= +Private Function IsNumerated(sText$) As Boolean + IsNumerated = True + + If sText Like "#### *" Or sText Like "!#### *" Then _ + Exit Function + If sText Like "### *" Or sText Like "!### *" Then _ + Exit Function + If sText Like "## *" Or sText Like "!## *" Then _ + Exit Function + If sText Like "# *" Or sText Like "!# *" Then _ + Exit Function + If sText Like "[?][?][?] *" Then _ + Exit Function + + IsNumerated = False +End Function diff --git a/src/Declarations.bas b/src/Declarations.bas new file mode 100644 index 0000000..dcd76eb --- /dev/null +++ b/src/Declarations.bas @@ -0,0 +1,112 @@ +Attribute VB_Name = "Declarations" +Option Private Module +Option Explicit + +Public Const MASTER_BLOCK = "" +Public Const MASTER_ELEMENT = "" +Public Const MASTER_IDENTIFICATION = "" +Public Const MASTER_HEADER = "" +Public Const MASTER_SCHEMA = "" +Public Const MASTER_OPERATION = "" +Public Const MASTER_PROXY = "" +Public Const MASTER_MINIATURE = "" + +Public Const SHAPE_BLOCK = "Blocks.Block" +Public Const SHAPE_ELEMENT = "Blocks.Element" +Public Const SHAPE_IDENTIFICATION = "Blocks.IdentityPair" +Public Const SHAPE_HEADER = "Blocks.Header" +Public Const SHAPE_SCHEMA = "Blocks.SchemaContainer" +Public Const SHAPE_OPERATION = "Blocks.OperationContainer" +Public Const SHAPE_PROXY = "Blocks.Proxy" +Public Const SHAPE_MINIATURE = "Blocks.Summary" + +Public Const OPERATION_GAP = 30# / 25.4 ' mm to inches +Public Const HEADER_MARGINS = 20# / 25.4 +Public Const HEADER_MAX_WIDTH = 1300 / 25.4 +Public Const MINIATURE_OFFSET = 5# / 25.4 +Public Const MINIATURE_HEIGHT_MULTIPLIER = 1.75 + +Public Const CELLSU_CONTAINER_MARGINS = "User.msvSDContainerMargin" +Public Const CELLSU_BLOCK_HEADER = "User.ShowHeader" +Public Const CELLSU_ELEMENT_TYPE = "User.UType" +Public Const CELLSU_IS_INHERITED = "User.IsInherited" +Public Const CELLSU_IS_HIGHTLIGHT = "User.IsHighlight" + +Public Const TEMPLATE_PREFIX = "" +Public Const SERVER_TEMPLATES = "\\fs1.concept.ru\projects\10 \01 \-\" +Public Const HELP_FILE_PATH = "\\fs1.concept.ru\projects\10 \01 \-\! .docx" + +' Type of schema element +Public Enum TElement + T_EL_UNKNOWN = 0 + [_First] = 1 + + T_EL_BASIC = 1 + T_EL_DERIVED = 2 + T_EL_ASSERTION = 3 + T_EL_COMMENT = 4 + T_EL_INTERPRETATION = 5 + + T_EL_SCHEMA = 6 + T_EL_PROXY = 7 + T_EL_BLOCK = 8 + T_EL_OPERATION = 9 + T_EL_IDENTITY = 10 + + [_Last] = 10 + T_EL_HEADER = 20 + T_EL_MINIATURE = 21 +End Enum + +' Schema entity type +Public Enum TSchemaEntity + T_SE_COMMENT = 0 + T_SE_BASIC = 1 + T_SE_DERIVED = 2 + T_SE_INTERPRETATION = 3 + T_SE_ASSERTION = 4 +End Enum + +' -------- Excel ------------- +Public Const XL_TEMPLATE_NAME = "-Excel.xltx" + +Public Const XL_SHEET_SHAPES = "" +Public Const XL_SHEET_LINKS = "" + +Public Enum OutXLShapesStruct + [_First] = 1 + + S_XLS_ID = 1 + S_XLS_TYPE = 2 + S_XLS_POWER = 3 + S_XLS_TEXT1 = 4 + S_XLS_TEXT2 = 5 + S_XLS_CONTAINED = 6 + S_XLS_INHERITED = 7 + S_XLS_HIGHLIGHT = 8 + S_XLS_PINX = 9 + S_XLS_PINY = 10 + S_XLS_WIDTH = 11 + S_XLS_HEIGHT = 12 + + [_Last] = 12 +End Enum + +Public Enum OutXLLinksStruct + [_First] = 1 + + S_XLL_ID = 1 + S_XLL_SOURCE = 2 + S_XLL_DESTINATION = 3 + S_XLL_TEXT = 4 + + [_Last] = 4 +End Enum + +' -------- Word ------------- +Public Const WD_TEMPLATE_NAME = "-Word.dotx" + +Public Const WB_STYLE_TEXT = "! " +Public Const WB_STYLE_SCHEMA = " 2" +Public Const WB_STYLE_COMMENT = "! " +Public Const WB_STYLE_INTERPRETATION = "! " diff --git a/src/DevHelper.bas b/src/DevHelper.bas new file mode 100644 index 0000000..a2bde60 --- /dev/null +++ b/src/DevHelper.bas @@ -0,0 +1,24 @@ +Attribute VB_Name = "DevHelper" +Option Private Module +Option Explicit + +Public Function Dev_PrepareSkeleton() + ' Do nothing + Call ClearAll +End Function + +Public Function Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_Operations" + Dim sTest$: sTest = "t_ToggleThemeColors" + Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest) + Debug.Print sMsg + Call MsgBox(sMsg) +End Function + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + Case "s_DataAccess": Set Dev_GetTestSuite = New s_DataAccess + Case "s_ContextActions": Set Dev_GetTestSuite = New s_ContextActions + Case "s_Operations": Set Dev_GetTestSuite = New s_Operations + End Select +End Function diff --git a/src/Main.bas b/src/Main.bas new file mode 100644 index 0000000..bd968f2 --- /dev/null +++ b/src/Main.bas @@ -0,0 +1,269 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Const PRODUCT_VERSION = "1.3.0" +Public Const PRODUCT_NAME = "Concept-Blocks" + +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 RunToggleHeaders() +Attribute RunToggleHeaders.VB_ProcData.VB_Invoke_Func = "t" + Call GlobalUndo.BeginScope("") + ThisDocument.DiagramServicesEnabled = visServiceStructureFull + + Dim iSelected As Visio.Selection: Set iSelected = ActiveWindow.Selection + If iSelected.Count <> 0 Then + Call ToggleHeadersSelected(iSelected) + Else + Call ToggleHeadersAll(ActivePage) + End If + + ActiveWindow.Selection = iSelected + + ThisDocument.DiagramServicesEnabled = 0 + Call GlobalUndo.EndScope +End Sub + +Public Sub RunWidthAdd10() +Attribute RunWidthAdd10.VB_ProcData.VB_Invoke_Func = "e" + Call CC_WidthAdd10 +End Sub + +Public Sub RunWidthSub10() +Attribute RunWidthSub10.VB_ProcData.VB_Invoke_Func = "q" + Call CC_WidthSub10 +End Sub + +Public Sub RunGotoLinkBegin() +Attribute RunGotoLinkBegin.VB_ProcData.VB_Invoke_Func = "Q" + Call CC_GotoLinkBegin +End Sub + +Public Sub RunGotoLinkEnd() +Attribute RunGotoLinkEnd.VB_ProcData.VB_Invoke_Func = "E" + Call CC_GotoLinkEnd +End Sub + +Public Sub RunToggleMiniatures() +Attribute RunToggleMiniatures.VB_ProcData.VB_Invoke_Func = "T" + Call GlobalUndo.BeginScope(" ") + + Call ToggleMiniatures(ActivePage) + Call ActiveWindow.DeselectAll + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunToggleHighlight() +Attribute RunToggleHighlight.VB_ProcData.VB_Invoke_Func = "R" + Call GlobalUndo.BeginScope(" ") + + Call ToggleHighlight(ActiveWindow.Selection) + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunToggleInherited() + Call GlobalUndo.BeginScope(" ") + + Call ToggleInherited(ActiveWindow.Selection) + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunCycleElementType() +Attribute RunCycleElementType.VB_ProcData.VB_Invoke_Func = "r" + If ActiveWindow.Selection.Count = 0 Then + Call UserInteraction.ShowMessage(EM_SELECT_ELEMENT) + Exit Sub + End If + + Call GlobalUndo.BeginScope(" ") + + Dim aShape As Visio.Shape + For Each aShape In ActiveWindow.Selection + Call CycleElementType(aShape) + Next aShape + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunReflectParents() + If ActiveWindow.Selection.Count <> 1 Then + Call UserInteraction.ShowMessage(EM_SELECT_SCHEMA) + Exit Sub + End If + + Call GlobalUndo.BeginScope("") + ThisDocument.DiagramServicesEnabled = visServiceStructureBasic + + Call ReflectParents(ActiveWindow.Selection(1)) + + ThisDocument.DiagramServicesEnabled = 0 + Call GlobalUndo.EndScope +End Sub + +Public Sub RunEnumerateSchemas() + Call GlobalUndo.BeginScope(" ") + Call EnumerateSchemasOn(ActivePage) + Call GlobalUndo.EndScope +End Sub + +Public Sub RunFixEnumeration() + Call GlobalUndo.BeginScope(" ") + Call FixEnumerationOn(ActivePage) + Call GlobalUndo.EndScope +End Sub + +Public Sub RunExportWord() + Dim iExporter As New WordExporter + If Not iExporter.Init(ThisDocument.Path) Then _ + Exit Sub + + Dim iPage As Visio.Page: Set iPage = ActivePage + Dim iOrder As Collection: Set iOrder = GeotopSort(iPage, ScanGraph(ExtractGraphNodes(iPage), False)) + + Call CSE_ProgressBar.Init(" ", maxVal:=iOrder.Count) + Call CSE_ProgressBar.ShowModeless + + Call iExporter.Export(iPage, iOrder) + + Call Unload(CSE_ProgressBar) + + Call UserInteraction.ShowMessage(IM_EXPORT_OK) +End Sub + +Public Sub RunExportExcel() + Dim iExporter As New XLExporter + If Not iExporter.Init(ThisDocument.Path) Then _ + Exit Sub + + Call CSE_ProgressBar.Init(" ", maxVal:=ActivePage.Shapes.Count) + Call CSE_ProgressBar.ShowModeless + Call iExporter.Export(ActivePage) + Call Unload(CSE_ProgressBar) + + Call UserInteraction.ShowMessage(IM_EXPORT_OK) +End Sub + +Public Sub RunToggleColorTheme() + Call GlobalUndo.BeginScope(" ") + Call ToggleThemeColors(ActivePage) + Call GlobalUndo.EndScope +End Sub + +Public Sub RunHelp() + Dim wordWrap As New API_WordWrapper + Dim helpDoc As Word.Document: Set helpDoc = wordWrap.OpenDocument(HELP_FILE_PATH, bReadOnly:=True) + If helpDoc Is Nothing Then _ + Exit Sub + With helpDoc + .ActiveWindow.View.ReadingLayout = False + Call .Application.Activate + End With +End Sub + +' ===== Context menu API ======== +Public Function ToggleHeaderFor(target As Visio.Shape) + Call GlobalUndo.BeginScope("") + ThisDocument.DiagramServicesEnabled = visServiceStructureFull + + Dim iSelected As Visio.Selection: Set iSelected = ActiveWindow.Selection + Dim bShow As Boolean: bShow = CellsGetValue(target, CELLSU_BLOCK_HEADER) + Call ShowHeader(target, Not bShow) + ActiveWindow.Selection = iSelected + + ThisDocument.DiagramServicesEnabled = 0 + Call GlobalUndo.EndScope +End Function + +Public Function MinimizeListContainer(target As Visio.Shape) + If target.Shapes.Count <> 2 Then + Call UserInteraction.ShowMessage(EM_MINIMIZE_CONTAINERS_ONLY) + Exit Function + End If + + Call GlobalUndo.BeginScope("") + + Call target.Resize(visResizeDirS, target.Shapes(2).CellsU("Height") - target.CellsU("Height"), visInches) + + Call GlobalUndo.EndScope +End Function + +Public Function FixElementsWidthFor(target As Visio.Shape) + ThisDocument.DiagramServicesEnabled = visServiceStructureBasic + + Dim itemWidth As Double: itemWidth = target.CellsU("Width") - 2 * target.CellsU(CELLSU_CONTAINER_MARGINS) + Dim memberID As Variant + Dim itemShape As Visio.Shape + For Each memberID In target.ContainerProperties.GetListMembers + Set itemShape = target.ContainingPage.Shapes.ItemFromID(memberID) + Call itemShape.Resize(visResizeDirE, itemWidth - itemShape.CellsU("Width"), visInches) + Next memberID + + ThisDocument.DiagramServicesEnabled = 0 +End Function + +Public Function FitToContentsFor(target As Visio.Shape) + Dim tmp&: tmp = target.ContainerProperties.ResizeAsNeeded + target.ContainerProperties.ResizeAsNeeded = visContainerAutoResizeExpandContract + DoEvents + target.ContainerProperties.ResizeAsNeeded = tmp +End Function + +Public Function CreateProxyFor(target As Visio.Shape) + Call GlobalUndo.BeginScope(" ") + ThisDocument.DiagramServicesEnabled = visServiceStructureFull + + Dim iProxy As Visio.Shape: Set iProxy = CreateProxyShape(target) + Call ActiveWindow.Select(iProxy, visSelect) + + ThisDocument.DiagramServicesEnabled = 0 + Call GlobalUndo.EndScope +End Function + +Public Function CreateOperationFor(target As Visio.Shape) + If CountInboundConnects(target) < 1 Then + Call UserInteraction.ShowMessage(EM_OPERANDS_MISSING) + Exit Function + End If + + Call GlobalUndo.BeginScope(" ") + ThisDocument.DiagramServicesEnabled = visServiceStructureFull + + Dim iOperation As Visio.Shape: Set iOperation = CreateOperationShape(target) + Call ActiveWindow.Select(iOperation, visSelect) + + ThisDocument.DiagramServicesEnabled = 0 + Call GlobalUndo.EndScope +End Function + +Public Function RenameSchema(target As Visio.Shape) + Dim sInput$: sInput = UserInteraction.PromptInput(" ", sInitial:=TrimEnumerator(target.Text)) + If sInput = vbNullString Then _ + Exit Function + + Call GlobalUndo.BeginScope(" ") + Call RenameSchemaDeep(target, sInput) + Call GlobalUndo.EndScope +End Function + +' ========== +Private Function CountInboundConnects(target As Visio.Shape) As Long + Dim nCount& + Dim iConnect As Visio.Connect + For Each iConnect In target.FromConnects + If target = iConnect.FromSheet.Connects(2).ToSheet Then _ + nCount = nCount + 1 + Next iConnect + CountInboundConnects = nCount +End Function diff --git a/src/MainImpl.bas b/src/MainImpl.bas new file mode 100644 index 0000000..529faaf --- /dev/null +++ b/src/MainImpl.bas @@ -0,0 +1,376 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + +Public Function ClearAll() + Call VsoClearPage(ActivePage) +End Function + +Public Function CycleElementType(target As Visio.Shape) + If Not target.CellExistsU(CELLSU_ELEMENT_TYPE, visExistsAnywhere) Then _ + Exit Function + + Select Case (target.CellsU(CELLSU_ELEMENT_TYPE)) + Case T_SE_BASIC: target.CellsU(CELLSU_ELEMENT_TYPE) = 2 + Case T_SE_DERIVED: target.CellsU(CELLSU_ELEMENT_TYPE) = 4 + Case T_SE_ASSERTION: target.CellsU(CELLSU_ELEMENT_TYPE) = 0 + Case T_SE_COMMENT: target.CellsU(CELLSU_ELEMENT_TYPE) = 3 + Case T_SE_INTERPRETATION: target.CellsU(CELLSU_ELEMENT_TYPE) = 1 + Case Else: target.CellsU(CELLSU_ELEMENT_TYPE) = 1 + End Select +End Function + +Public Function ToggleInherited(targets As Visio.Selection) + Dim aShape As Visio.Shape + For Each aShape In targets + If aShape.CellExistsU(CELLSU_IS_INHERITED, visExistsAnywhere) Then _ + aShape.CellsU(CELLSU_IS_INHERITED).FormulaU = IIf(aShape.CellsU(CELLSU_IS_INHERITED).Result(visLogical), "FALSE", "TRUE") + Next aShape +End Function + +Public Function ToggleHighlight(targets As Visio.Selection) + Dim aShape As Visio.Shape + For Each aShape In targets + If aShape.CellExistsU(CELLSU_IS_HIGHTLIGHT, visExistsAnywhere) Then _ + aShape.CellsU(CELLSU_IS_HIGHTLIGHT).FormulaU = IIf(aShape.CellsU(CELLSU_IS_HIGHTLIGHT).Result(visLogical), "FALSE", "TRUE") + Next aShape +End Function + +Public Function ToggleMiniatures(target As Visio.Page) + If ClearMiniatures(target) = 0 Then _ + Call CreateMiniatures(target) +End Function + +Public Function EnumerateSchemasOn(target As Visio.Page) + Dim shapeOrder As Collection: Set shapeOrder = GeotopSort(target, ScanGraph(ExtractGraphNodes(target), False)) + Dim indexBase As Scripting.Dictionary: Set indexBase = EnumerateSchemas(shapeOrder) + Call EnumerateProxies(shapeOrder, indexBase) +End Function + +Public Function FixEnumerationOn(target As Visio.Page) + Dim shapeOrder As Collection: Set shapeOrder = GeotopSort(target, ScanGraph(ExtractGraphNodes(target), False)) + Dim indexBase As New Scripting.Dictionary: Set indexBase = FixSchemas(target, shapeOrder) + Call EnumerateProxies(shapeOrder, indexBase) +End Function + +Public Function ReflectParents(target As Visio.Shape) + Dim iGraph As CDS_Graph: Set iGraph = ScanGraph(CColl(target), True) + + Dim dBaseX As Double: dBaseX = target.CellsU("PinX") + + Dim nShapeID As Variant + Dim aShape As Visio.Shape + For Each nShapeID In iGraph.Nodes + Set aShape = target.Parent.Shapes.ItemFromID(nShapeID) + If aShape.MasterShape.Name = SHAPE_OPERATION Then _ + Call SwapIdentifications(aShape) + aShape.CellsU("PinX") = dBaseX + (dBaseX - aShape.CellsU("PinX")) + Next nShapeID +End Function + +Public Function ToggleThemeColors(iPage As Visio.Page) + Dim aShape As Visio.Shape + Dim bFirst As Boolean: bFirst = True + Dim bMakeLighter As Boolean + For Each aShape In iPage.Shapes + If aShape.MasterShape.Name <> SHAPE_ELEMENT Then _ + GoTo NEXT_SHAPE + + If bFirst Then + bFirst = False + bMakeLighter = aShape.CellsU("User.Color1").FormulaU <> "RGB(233,244,226)" + End If + + Call ToggleElementColor(aShape, bMakeLighter) + +NEXT_SHAPE: + Next aShape +End Function + +Public Function CreateOperationShape(target As Visio.Shape) As Visio.Shape + Dim iOperation As Visio.Shape + With target + Set iOperation = .ContainingPage.Drop(FindMaster(.Document, MASTER_OPERATION), .CellsU("PinX"), .CellsU("PinY")) + iOperation.CellsU("PinY") = .CellsU("PinY") + .CellsU("Height") / 2# + iOperation.CellsU("Height") / 2# + OPERATION_GAP + End With + + Dim connection As Visio.Connect + For Each connection In target.FromConnects + If target = connection.FromSheet.Connects(2).ToSheet Then _ + Call connection.FromSheet.CellsU("EndX").GlueTo(iOperation.CellsSRC(7, 1, 0)) + Next connection + + Call iOperation.AutoConnect(target, visAutoConnectDirNone) + Set CreateOperationShape = iOperation +End Function + +Public Function CreateProxyShape(target As Visio.Shape) As Visio.Shape + Dim newShape As Visio.Shape + With target + Set newShape = .ContainingPage.Drop(FindMaster(.Document, MASTER_PROXY), .CellsU("PinX"), .CellsU("PinY")) + newShape.Text = .Text + newShape.CellsU("PinX") = .CellsU("PinX") + .CellsU("Width") / 2# + newShape.CellsU("Width") / 2# + End With + Set CreateProxyShape = newShape +End Function + +Public Function ToggleHeadersSelected(iSelected As Visio.Selection) + Dim aShape As Visio.Shape + Dim bShow As Boolean + For Each aShape In iSelected + If GetShapeType(aShape) <> T_EL_BLOCK Then _ + GoTo NEXT_SHAPE + + bShow = CellsGetValue(aShape, CELLSU_BLOCK_HEADER) + Call ShowHeader(aShape, Not bShow) + +NEXT_SHAPE: + Next aShape +End Function + +Public Function ToggleHeadersAll(iPage As Visio.Page) + Dim aShape As Visio.Shape + Dim bFirst As Boolean: bFirst = True + Dim bShow As Boolean + For Each aShape In iPage.Shapes + If GetShapeType(aShape) <> T_EL_BLOCK Then _ + GoTo NEXT_SHAPE + + If bFirst Then + bFirst = False + bShow = CellsGetValue(aShape, CELLSU_BLOCK_HEADER) + bShow = Not bShow + End If + + Call ShowHeader(aShape, bShow) + +NEXT_SHAPE: + Next aShape +End Function + +Public Function ShowHeader(target As Visio.Shape, bShow As Boolean) As Visio.Shape + Call ResetHeader(target) + Call CellsSetValue(target, CELLSU_BLOCK_HEADER, bShow) + If bShow Then _ + Set ShowHeader = CreateHeader(target) +End Function + +Public Function GeotopSort(iPage As Visio.Page, iGraph As CDS_Graph) As Collection + If iGraph.Size = 0 Then + Set GeotopSort = New Collection + Exit Function + End If + + Dim ids() As Long: ids = ToLongArray(iGraph.Nodes) + Call VsoGeometricSort(ids, iPage) + + Dim iSorter As New API_GraphOrdering: Call iSorter.Init(iGraph) + Set GeotopSort = iSorter.SortLayers(FromArray(ids)) +End Function + +Public Function RenameSchemaDeep(target As Visio.Shape, sInput$) + Dim sPrefix$: sPrefix = target.Text + Dim sName$: sName = TrimEnumerator(target.Text) + If sName = sPrefix Then + sPrefix = vbNullString + Else + sPrefix = VBA.Left(sPrefix, VBA.Len(sPrefix) - VBA.Len(sName)) + End If + + target.Text = sPrefix & sInput + Call RenameProxies(target.Parent, sPrefix, sName, sInput) +End Function + +' =========== +Private Function ResetHeader(target As Visio.Shape) + Dim memberID As Variant + Dim iPage As Visio.Page: Set iPage = target.ContainingPage + Dim itemShape As Visio.Shape + For Each memberID In target.ContainerProperties.GetMemberShapes(visContainerFlagsDefault) + Set itemShape = iPage.Shapes.ItemFromID(memberID) + If GetShapeType(itemShape) = T_EL_HEADER Then + Call itemShape.Delete + Exit Function + End If + Next memberID +End Function + +Private Function CreateHeader(target) As Visio.Shape + Dim newShape As Visio.Shape + With target + Set newShape = .ContainingPage.Drop(FindMaster(.Document, MASTER_HEADER), .CellsU("PinX"), .CellsU("PinY")) + newShape.CellsU("LockTextEdit") = 0 + newShape.Text = .Text + newShape.CellsU("LockTextEdit") = 1 + newShape.CellsU("Width") = IIf(HEADER_MAX_WIDTH > .CellsU("Width") - HEADER_MARGINS, .CellsU("Width") - HEADER_MARGINS, HEADER_MAX_WIDTH) + End With + Set CreateHeader = newShape +End Function + +Private Function ClearMiniatures(target As Visio.Page) As Long + Dim cDelete As New Collection + Dim iShape As Visio.Shape + For Each iShape In target.Shapes + If GetShapeType(iShape) = T_EL_MINIATURE Then _ + Call cDelete.Add(iShape) + Next iShape + + For Each iShape In cDelete + Call iShape.Delete + Next iShape + + ClearMiniatures = cDelete.Count +End Function + +Private Function CreateMiniatures(target As Visio.Page) + Dim sText$ + Dim dHeight As Double + Dim iMiniature As Visio.Shape + Dim iSchema As Visio.Shape + For Each iSchema In ExtractSchemas(target) + Set iMiniature = target.Drop(FindMaster(iSchema.Document, MASTER_MINIATURE), iSchema.CellsU("PinX"), iSchema.CellsU("PinY")) + iMiniature.CellsU("Width") = iSchema.CellsU("Width") + 2 * MINIATURE_OFFSET + iMiniature.Shapes(2).Text = iSchema.Text + + dHeight = 0 + sText = "" + + Dim nElement As Variant + Dim iElement As Visio.Shape + Dim elems As Variant: elems = iSchema.ContainerProperties.GetListMembers + For Each nElement In elems + Set iElement = target.Shapes.ItemFromID(nElement) + If CellsGetValue(iElement, CELLSU_IS_HIGHTLIGHT) Then + dHeight = dHeight + iElement.CellsU("Height") + If sText = vbNullString Then + sText = iElement.Text + Else + sText = sText & vbNewLine & iElement.Text + End If + End If + Next nElement + + iMiniature.Shapes(1).Text = sText + iMiniature.CellsU("Height") = iMiniature.Shapes(2).CellsU("Height") + dHeight * MINIATURE_HEIGHT_MULTIPLIER + iMiniature.CellsU("PinY") = iSchema.CellsU("PinY") + iSchema.CellsU("Height") / 2# - iMiniature.CellsU("Height") / 2# + MINIATURE_OFFSET + + Next iSchema +End Function + +Private Function SwapIdentifications(target As Visio.Shape) + Dim memberID As Variant + Dim member As Visio.Shape + For Each memberID In target.ContainerProperties.GetListMembers + Set member = target.ContainingPage.Shapes.ItemFromID(memberID) + If member.MasterShape.Name = SHAPE_IDENTIFICATION Then + Dim sText$: sText = member.Shapes(1).Text + member.Shapes(1).Text = member.Shapes(2).Text + member.Shapes(2).Text = sText + End If + Next memberID +End Function + +Private Function EnumerateSchemas(shapeOrder As Collection) As Scripting.Dictionary + Dim indexBase As New Scripting.Dictionary + Dim nNext&: nNext = 1 + Dim shapeID As Variant + Dim aShape As Visio.Shape + For Each shapeID In shapeOrder + Set aShape = ActivePage.Shapes.ItemFromID(shapeID) + If aShape.MasterShape.Name = SHAPE_SCHEMA Then + Dim sText$: sText = TrimEnumerator(aShape.Text) + If Not indexBase.Exists(sText) Then + Call indexBase.Add(sText, nNext) + nNext = nNext + 1 + aShape.Text = AppendEnumerator(sText, indexBase(sText)) + Else + aShape.Text = "!" + AppendEnumerator(sText, indexBase(sText)) + End If + End If + Next shapeID + Set EnumerateSchemas = indexBase +End Function + +Private Function EnumerateProxies(iOrder As Collection, indexBase As Scripting.Dictionary) + Dim shapeID As Variant + Dim aShape As Visio.Shape + For Each shapeID In iOrder + Set aShape = ActivePage.Shapes.ItemFromID(shapeID) + If aShape.MasterShape.Name = SHAPE_PROXY Then + Dim sText$: sText = TrimEnumerator(aShape.Text) + If Not indexBase.Exists(sText) Then + aShape.Text = "??? " + sText + Else + aShape.Text = AppendEnumerator(sText, indexBase(sText)) + End If + End If + Next shapeID +End Function + +Private Function FixSchemas(iPage As Visio.Page, iOrder As Collection) As Scripting.Dictionary + Dim indexBase As New Scripting.Dictionary + Dim nMaxIndex&: nMaxIndex = 0 + + Dim sText$ + Dim aShape As Visio.Shape + Dim shapeID As Variant + For Each shapeID In iOrder + Set aShape = iPage.Shapes.ItemFromID(shapeID) + If aShape.MasterShape.Name <> SHAPE_SCHEMA Then _ + GoTo NEXT_SHAPE + + Dim enumerator&: enumerator = ExtractEnumerator(aShape.Text) + If enumerator = 0 Then _ + GoTo NEXT_SHAPE + If enumerator > nMaxIndex Then _ + nMaxIndex = enumerator + + sText = TrimEnumerator(aShape.Text) + If Not indexBase.Exists(sText) Then + Call indexBase.Add(sText, enumerator) + Else + aShape.Text = "!" + AppendEnumerator(sText, enumerator) + End If +NEXT_SHAPE: + Next shapeID + + Dim nextIndex&: nextIndex = nMaxIndex + 1 + For Each shapeID In iOrder + Set aShape = iPage.Shapes.ItemFromID(shapeID) + If aShape.MasterShape.Name = SHAPE_SCHEMA Then + sText = TrimEnumerator(aShape.Text) + If Not indexBase.Exists(sText) Then + Call indexBase.Add(sText, nextIndex) + nextIndex = nextIndex + 1 + aShape.Text = AppendEnumerator(sText, indexBase(sText)) + End If + End If + Next shapeID + + Set FixSchemas = indexBase +End Function + +Private Function RenameProxies(iPage As Visio.Page, sPrefix$, sOldName$, sNewName$) + Dim aShape As Visio.Shape + For Each aShape In iPage.Shapes + If aShape.MasterShape.Name = SHAPE_PROXY Then _ + If TrimEnumerator(aShape.Text) = sOldName Then _ + aShape.Text = sPrefix & sNewName + Next aShape +End Function + +Private Function ToggleElementColor(target As Visio.Shape, bMakeLighter As Boolean) + With target + If bMakeLighter Then + .CellsU("User.Color1").FormulaU = "RGB(233,244,226)" + .CellsU("User.Color2").FormulaU = "RGB(213,241,255)" + .CellsU("User.Color3").FormulaU = "RGB(238,227,240)" + .CellsU("User.Color4").FormulaU = "RGB(255,216,213)" + Else + .CellsU("User.Color1").FormulaU = "=" + .CellsU("User.Color2").FormulaU = "=" + .CellsU("User.Color3").FormulaU = "=" + .CellsU("User.Color4").FormulaU = "=" + End If + End With +End Function diff --git a/src/PowerEstimator.cls b/src/PowerEstimator.cls new file mode 100644 index 0000000..b36820c --- /dev/null +++ b/src/PowerEstimator.cls @@ -0,0 +1,71 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "PowerEstimator" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Estimate power level according to graph synthesis ==== +Option Explicit + +Private graph_ As CDS_Graph +Private powerLevels_ As Scripting.Dictionary +Private visiting_ As Scripting.Dictionary +Private reps_ As Scripting.Dictionary + +Public Function Estimate(iGraph As CDS_Graph, iOrder As Collection, iReps As Scripting.Dictionary) As Scripting.Dictionary + Set graph_ = iGraph + Set reps_ = iReps + Call Reset + + Dim vNode As Variant + For Each vNode In iOrder + Call GetPowerRecursive(vNode) + Next vNode + + Set Estimate = powerLevels_ +End Function + +' =========== +Private Function Reset() + Set powerLevels_ = New Scripting.Dictionary + Set visiting_ = New Scripting.Dictionary + Set reps_ = New Scripting.Dictionary +End Function + +Private Function GetPowerRecursive(vNode As Variant) As Long + If reps_.Exists(vNode) Then _ + vNode = reps_(vNode) + + If visiting_.Exists(vNode) Then + Call MsgBox("! !", vbExclamation) ' TODO: extract message and raise error instead + GetPowerRecursive = 0 + Exit Function + End If + + If powerLevels_.Exists(vNode) Then + GetPowerRecursive = powerLevels_(vNode) + Exit Function + End If + + Call visiting_.Add(vNode, 0) + + Dim parentCount&: parentCount = graph_.nodes_(vNode).inputs_.Count + Dim nLevel& + If parentCount = 0 Then + nLevel = 1 + Else + nLevel = 0 + Dim vChild As Variant + For Each vChild In graph_.nodes_(vNode).inputs_ + nLevel = nLevel + GetPowerRecursive(vChild) + Next vChild + End If + + Call visiting_.Remove(vNode) + + Call powerLevels_.Add(vNode, nLevel) + GetPowerRecursive = nLevel +End Function 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/WordExporter.cls b/src/WordExporter.cls new file mode 100644 index 0000000..0712b83 --- /dev/null +++ b/src/WordExporter.cls @@ -0,0 +1,82 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "WordExporter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private app_ As API_WordWrapper +Private out_ As Word.Document +Private source_ As Visio.Page + +Public Function Init(sLocalTemplates$) As Boolean + Init = False + + Set app_ = New API_WordWrapper + Dim sTemplate$: sTemplate = GetTemplate(WD_TEMPLATE_NAME, sLocalTemplates) + If sTemplate = vbNullString Then + Call UserInteraction.ShowMessage(EM_WORD_MISSING_TEMPLATE) + Exit Function + End If + Set out_ = app_.NewDocument(sTemplate) + If out_ Is Nothing Then _ + Exit Function + + Init = True +End Function + +Public Function Export(iSource As Visio.Page, iOrder As Collection) + Set source_ = iSource + Call app_.PauseUI + + Dim shapeID As Variant + Dim aShape As Visio.Shape + For Each shapeID In iOrder + Set aShape = source_.Shapes.ItemFromID(CLng(shapeID)) + If aShape.MasterShape.Name = SHAPE_SCHEMA Then _ + Call ExportSchema(aShape) + Call CSE_ProgressBar.IncrementA + Next shapeID + Call out_.TablesOfContents(1).Update + + Call app_.ResumeUI +End Function + +' ======== +Private Function ExportSchema(target As Visio.Shape) + Dim textPos As Word.Range + Set textPos = WordAddLine(VBA.Trim(target.Text), out_.Content, WB_STYLE_SCHEMA) + + Dim nCount&: nCount = UBound(target.ContainerProperties.GetListMembers) + 1 + If nCount = 0 Then _ + Exit Function + + Dim memberID As Variant + Dim bFirst As Boolean: bFirst = True + Dim aShape As Visio.Shape + For Each memberID In target.ContainerProperties.GetListMembers + Set aShape = source_.Shapes.ItemFromID(memberID) + Set textPos = WordAddLine(VBA.Trim(aShape.Text), textPos, ElementStyle(aShape)) + If Not bFirst Then _ + Set textPos = WordAddLine(vbNullString, textPos, WB_STYLE_TEXT) + bFirst = False + Next memberID +End Function + +Private Function ElementStyle(target As Visio.Shape) As String + If Not target.CellExistsU(CELLSU_ELEMENT_TYPE, visExistsAnywhere) Then _ + ElementStyle = WB_STYLE_TEXT + + Select Case (target.CellsU(CELLSU_ELEMENT_TYPE)) + Case T_SE_BASIC: ElementStyle = WB_STYLE_TEXT + Case T_SE_DERIVED: ElementStyle = WB_STYLE_TEXT + Case T_SE_ASSERTION: ElementStyle = WB_STYLE_TEXT + Case T_SE_COMMENT: ElementStyle = WB_STYLE_COMMENT + Case T_SE_INTERPRETATION: ElementStyle = WB_STYLE_INTERPRETATION + Case Else: ElementStyle = WB_STYLE_TEXT + End Select +End Function diff --git a/src/XLExporter.cls b/src/XLExporter.cls new file mode 100644 index 0000000..8e46ca8 --- /dev/null +++ b/src/XLExporter.cls @@ -0,0 +1,106 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "XLExporter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private app_ As API_XLWrapper +Private outLinks_ As Excel.Worksheet +Private outShapes_ As Excel.Worksheet + +Private powers_ As Scripting.Dictionary +Private nLink_ As Long +Private nShape_ As Long + +Public Function Init(sLocalTemplates$) As Boolean + Set app_ = New API_XLWrapper + Dim sTemplate$: sTemplate = GetTemplate(XL_TEMPLATE_NAME, sLocalTemplates) + Init = Not app_.NewDocument(sTemplate, bDefaultIfFail:=True) Is Nothing + If Not Init Then _ + Exit Function + If sTemplate = vbNullString Then _ + Call PrepareDefaultOutput + Set outLinks_ = app_.Document.Sheets(XL_SHEET_LINKS) + Set outShapes_ = app_.Document.Sheets(XL_SHEET_SHAPES) +End Function + +Public Function Export(iSource As Visio.Page) + Call app_.PauseUI + + Set powers_ = ExtractPowerLevels(iSource) + nLink_ = 2 + nShape_ = 2 + Dim aShape As Visio.Shape + For Each aShape In iSource.Shapes + If aShape.OneD Then + If aShape.Connects.Count = 2 Then + Call ExportLink(aShape) + End If + Else + Call ExportShape(aShape) + End If + Call CSE_ProgressBar.IncrementA + Next aShape + + Call app_.ResumeUI +End Function + +' ========== +Private Function PrepareDefaultOutput() + Call UserInteraction.ShowMessage(EM_MISSING_TEMPLATE) + With app_.Document + .Sheets.Add + .Sheets(1).Name = XL_SHEET_SHAPES + .Sheets(2).Name = XL_SHEET_LINKS + End With +End Function + +Private Function ExportLink(target As Visio.Shape) + outLinks_.Cells(nLink_, S_XLL_ID) = target.ID + outLinks_.Cells(nLink_, S_XLL_SOURCE) = target.Connects(1).ToSheet.ID + outLinks_.Cells(nLink_, S_XLL_DESTINATION) = target.Connects(2).ToSheet.ID + outLinks_.Cells(nLink_, S_XLL_TEXT) = target.Text + nLink_ = nLink_ + 1 +End Function + +Private Function ExportShape(target As Visio.Shape) As Boolean + Dim nType As TElement: nType = GetShapeType(target) + If nType = T_EL_HEADER Or nType = T_EL_MINIATURE Then _ + Exit Function + + Dim bInherited As Boolean: bInherited = CellsGetValue(target, CELLSU_IS_INHERITED) + Dim bHighlighted As Boolean: bHighlighted = CellsGetValue(target, CELLSU_IS_HIGHTLIGHT) + Dim vParent As Visio.Shape: Set vParent = GetContainingShape(target) + + outShapes_.Cells(nShape_, S_XLS_ID) = target.ID + outShapes_.Cells(nShape_, S_XLS_TYPE) = nType + If powers_.Exists(target.ID) And nType = T_EL_SCHEMA Then _ + outShapes_.Cells(nShape_, S_XLS_POWER) = powers_(target.ID) + + If IsElementary(nType) Then + outShapes_.Cells(nShape_, S_XLS_INHERITED) = IIf(bInherited, "", "") + outShapes_.Cells(nShape_, S_XLS_HIGHLIGHT) = IIf(bHighlighted, "", "") + End If + + outShapes_.Cells(nShape_, S_XLS_PINX) = target.CellsU("PinX").Result(visMillimeters) + outShapes_.Cells(nShape_, S_XLS_PINY) = target.CellsU("PinY").Result(visMillimeters) + outShapes_.Cells(nShape_, S_XLS_WIDTH) = target.CellsU("Width").Result(visMillimeters) + outShapes_.Cells(nShape_, S_XLS_HEIGHT) = target.CellsU("Height").Result(visMillimeters) + + If Not vParent Is Nothing Then _ + outShapes_.Cells(nShape_, S_XLS_CONTAINED) = vParent.ID + + If nType <> T_EL_IDENTITY Then + outShapes_.Cells(nShape_, S_XLS_TEXT1) = target.Text + Else + outShapes_.Cells(nShape_, S_XLS_TEXT1) = target.Shapes(1).Text + outShapes_.Cells(nShape_, S_XLS_TEXT2) = target.Shapes(2).Text + End If + + nShape_ = nShape_ + 1 +End Function diff --git a/src/s_ContextActions.cls b/src/s_ContextActions.cls new file mode 100644 index 0000000..a41774d --- /dev/null +++ b/src/s_ContextActions.cls @@ -0,0 +1,164 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_ContextActions" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Test context shape actions ====== +Option Explicit + +Private page_ As Visio.Page + +Public Function Setup() + ' Mandatory setup function + Set page_ = ThisDocument.Application.ActivePage +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call ClearAll +End Function + +Public Function t_CycleElementType() + On Error GoTo PROPAGATE_ERROR + + Dim iShape As Visio.Shape + + Call Dev_NewCase("Not element") + Set iShape = page_.Drop(FindMaster(ThisDocument, MASTER_PROXY), 10, 10) + On Error Resume Next + Call CycleElementType(iShape) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid cycle") + Set iShape = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 0, 10) + Call CellsSetValue(iShape, CELLSU_ELEMENT_TYPE, T_SE_BASIC) + Call CycleElementType(iShape) + Call Dev_ExpectEQ(T_SE_DERIVED, iShape.CellsU(CELLSU_ELEMENT_TYPE)) + Call CycleElementType(iShape) + Call Dev_ExpectEQ(T_SE_ASSERTION, iShape.CellsU(CELLSU_ELEMENT_TYPE)) + Call CycleElementType(iShape) + Call Dev_ExpectEQ(T_SE_COMMENT, iShape.CellsU(CELLSU_ELEMENT_TYPE)) + Call CycleElementType(iShape) + Call Dev_ExpectEQ(T_SE_INTERPRETATION, iShape.CellsU(CELLSU_ELEMENT_TYPE)) + Call CycleElementType(iShape) + Call Dev_ExpectEQ(T_SE_BASIC, iShape.CellsU(CELLSU_ELEMENT_TYPE)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_RenameSchemaDeep() + On Error GoTo PROPAGATE_ERROR + + Dim iSchema As Visio.Shape: Set iSchema = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 0, 0) + Dim iDuplicate As Visio.Shape: Set iDuplicate = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 10, 10) + Dim iProxy As Visio.Shape: Set iProxy = page_.Drop(FindMaster(ThisDocument, MASTER_PROXY), 20, 20) + iSchema.Text = "01 Test" + iDuplicate.Text = "01 Test" + iProxy.Text = "Test" + + Call RenameSchemaDeep(iSchema, "Test2") + Call Dev_ExpectEQ("01 Test2", iSchema.Text, "Rename keep prefix") + Call Dev_ExpectEQ("01 Test", iDuplicate.Text, "Do not rename duplicates") + Call Dev_ExpectEQ("01 Test2", iProxy.Text, "Rename proxies") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CreateProxyShape() + On Error GoTo PROPAGATE_ERROR + + Dim iSchema As Visio.Shape: Set iSchema = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 0, 0) + iSchema.Text = "Test" + + Dim iProxy As Visio.Shape: Set iProxy = CreateProxyShape(iSchema) + Call Dev_AssertNotNothing(iProxy) + Call Dev_ExpectEQ(SHAPE_PROXY, iProxy.MasterShape.Name, "Proxy master") + Call Dev_ExpectEQ(iSchema.Text, iProxy.Text, "Proxy texxt") + Call Dev_ExpectNE(iSchema.CellsU("PinX"), iProxy.CellsU("PinX"), "Proxy position") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CreateOperationShape() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("No parents") + Dim iSchema As Visio.Shape: Set iSchema = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 0, 0) + Dim iOperation As Visio.Shape: Set iOperation = CreateOperationShape(iSchema) + Call Dev_AssertNotNothing(iOperation) + Call Dev_AssertEQ(3, page_.Shapes.Count, "Shapes count") + Call Dev_ExpectEQ(SHAPE_OPERATION, iOperation.MasterShape.Name, "Operation master") + Call Dev_ExpectAEQ(iOperation.CellsU("PinX"), iSchema.CellsU("PinX"), 1, "Operation position X") + Call Dev_ExpectGR(iOperation.CellsU("PinY"), iSchema.CellsU("PinY"), "Operation position Y") + Call Dev_ExpectTrue(VsoIsConnected(iOperation, iSchema), "Connection") + Call ClearAll + + Call Dev_NewCase("Valid parents") + Set iSchema = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 0, 0) + Dim iParent1 As Visio.Shape: Set iParent1 = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 10, 10) + Dim iParent2 As Visio.Shape: Set iParent2 = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), -10, 10) + Dim iChild As Visio.Shape: Set iChild = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 0, -10) + Call iParent1.AutoConnect(iSchema, visAutoConnectDirDown) + Call iParent2.AutoConnect(iSchema, visAutoConnectDirDown) + Call iSchema.AutoConnect(iChild, visAutoConnectDirDown) + + Set iOperation = CreateOperationShape(iSchema) + Call Dev_AssertEQ(9, page_.Shapes.Count, "Shapes count") + Call Dev_ExpectTrue(VsoIsConnected(iOperation, iSchema), "New Connection") + Call Dev_ExpectTrue(VsoIsConnected(iParent1, iOperation), "Connection redirect1") + Call Dev_ExpectTrue(VsoIsConnected(iParent2, iOperation), "Connection redirect2") + Call Dev_ExpectTrue(VsoIsConnected(iSchema, iChild), "Do not redirect child") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ShowHeader() + On Error GoTo PROPAGATE_ERROR + + ThisDocument.DiagramServicesEnabled = visServiceStructureFull + + Dim iBlock As Visio.Shape: Set iBlock = page_.Drop(FindMaster(ThisDocument, MASTER_BLOCK), 0, 0) + iBlock.Text = "Test" + + Call Dev_NewCase("Create valid header") + Dim iHeader As Visio.Shape: Set iHeader = ShowHeader(iBlock, bShow:=True) + Call Dev_AssertNotNothing(iHeader) + Call Dev_ExpectEQ(iBlock.Text, iHeader.Text, "Header text") + Call Dev_ExpectTrue(CellsGetValue(iBlock, CELLSU_BLOCK_HEADER), "Header flag") + Call Dev_ExpectAEQ(iBlock.CellsU("PinX"), iHeader.CellsU("PinX"), 1, "Header position") + + Call Dev_NewCase("Remove header") + Set iHeader = ShowHeader(iBlock, bShow:=False) + Call Dev_AssertNothing(iHeader) + Call Dev_ExpectEQ(1, page_.Shapes.Count, "Delete header") + Call Dev_ExpectFalse(CellsGetValue(iBlock, CELLSU_BLOCK_HEADER), "Header flag") + + Call Dev_NewCase("Change header") + Call ShowHeader(iBlock, bShow:=True) + iBlock.Text = "Test2" + Set iHeader = ShowHeader(iBlock, bShow:=True) + Call Dev_AssertNotNothing(iHeader) + Call Dev_ExpectEQ(2, page_.Shapes.Count, "Delete previous header") + Call Dev_ExpectEQ(iBlock.Text, iHeader.Text, "Header text") + Call Dev_ExpectTrue(CellsGetValue(iBlock, CELLSU_BLOCK_HEADER), "Header flag") + Call Dev_ExpectAEQ(iBlock.CellsU("PinX"), iHeader.CellsU("PinX"), 1, "Header position") + + ThisDocument.DiagramServicesEnabled = 0 + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/s_DataAccess.cls b/src/s_DataAccess.cls new file mode 100644 index 0000000..ff77089 --- /dev/null +++ b/src/s_DataAccess.cls @@ -0,0 +1,155 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_DataAccess" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private page_ As Visio.Page + +Public Function Setup() + ' Mandatory setup function + Set page_ = ThisDocument.Application.ActivePage +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call ClearAll +End Function + +Public Function t_Enumerator() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty string") + Call Dev_ExpectEQ("", TrimEnumerator("")) + Call Dev_ExpectEQ(0, ExtractEnumerator("")) + + Call Dev_NewCase("Invalid enumerated") + Call Dev_ExpectEQ("1.1 Test", TrimEnumerator("1.1 Test")) + Call Dev_ExpectEQ(0, ExtractEnumerator("1.1 Test")) + Call Dev_ExpectEQ("1.1. Test", TrimEnumerator("1.1. Test")) + Call Dev_ExpectEQ(0, ExtractEnumerator("1.1. Test")) + + Call Dev_NewCase("Valid enumerated") + Call Dev_ExpectEQ("Test1", TrimEnumerator("1 Test1")) + Call Dev_ExpectEQ(1, ExtractEnumerator("1 Test1")) + Call Dev_ExpectEQ("Test2", TrimEnumerator("!2 Test2")) + Call Dev_ExpectEQ(2, ExtractEnumerator("!2 Test2")) + Call Dev_ExpectEQ("Test3", TrimEnumerator("??? Test3")) + Call Dev_ExpectEQ(0, ExtractEnumerator("??? Test3")) + + Call Dev_NewCase("Extract appended") + Dim sText$: sText = AppendEnumerator("Test", 1337) + Call Dev_ExpectEQ("Test", TrimEnumerator(sText)) + Call Dev_ExpectEQ(1337, ExtractEnumerator(sText)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ExtractGraphNodes() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(0, ExtractGraphNodes(page_).Count, "Empty page") + + Call Dev_NewCase("Invalid shapes") + Call page_.DrawLine(0, 0, 1, 1) + Call page_.DrawRectangle(2, 2, 3, 3) + Call page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 10, 10) + Call page_.Drop(FindMaster(ThisDocument, MASTER_IDENTIFICATION), 15, 15) + Call Dev_ExpectEQ(0, ExtractGraphNodes(page_).Count) + + Call Dev_NewCase("Valid schemas") + Dim ks1 As Visio.Shape: Set ks1 = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 20, 20) + ks1.Text = "Test1" + Dim ks2 As Visio.Shape: Set ks2 = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 25, 25) + ks2.Text = "Test2" + Dim iOperation As Visio.Shape: Set iOperation = page_.Drop(FindMaster(ThisDocument, MASTER_OPERATION), 30, 30) + Dim iProxy As Visio.Shape: Set iProxy = page_.Drop(FindMaster(ThisDocument, MASTER_PROXY), 35, 35) + iProxy.Text = ks1.Text + Dim iBlock As Visio.Shape: Set iBlock = page_.Drop(FindMaster(ThisDocument, MASTER_BLOCK), 40, 40) + Dim iNodes As Collection: Set iNodes = CColl(ks1, ks2, iOperation, iProxy) + Call Dev_ExpectEQ(iNodes, ExtractGraphNodes(page_)) + + Call Dev_NewCase("Contained shapes") + Call iBlock.ContainerProperties.AddMember(ks2, visMemberAddExpandContainer) + Call Dev_ExpectEQ(iNodes, ExtractGraphNodes(page_)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ExtractRepresentatives() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(0, ExtractRepresentatives(page_).Count, "Empty page") + + Call Dev_NewCase("Literal representatives") + Dim iSchema As Visio.Shape: Set iSchema = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 20, 20) + iSchema.Text = "Test" + Dim iProxy As Visio.Shape: Set iProxy = page_.Drop(FindMaster(ThisDocument, MASTER_PROXY), 35, 35) + iProxy.Text = "Test" + Dim iReps As New Scripting.Dictionary + iReps(iProxy.ID) = iSchema.ID + Call Dev_ExpectEQ(iReps, ExtractRepresentatives(page_)) + + Call Dev_NewCase("Invalid enumerated representatives") + iSchema.Text = "2 Test" + iProxy.Text = "1 Test" + Call Dev_ExpectEQ(iReps, ExtractRepresentatives(page_)) + + Call Dev_NewCase("Unrelated proxy") + iSchema.Text = "1 Test" + iProxy.Text = "1 Test1337" + Call Dev_ExpectEQ(0, ExtractRepresentatives(page_).Count) + + Call Dev_NewCase("Duplicate schema") + Dim iDuplicate As Visio.Shape: Set iDuplicate = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 30, 30) + iDuplicate.Text = iSchema.Text + Call Dev_ExpectEQ(0, ExtractRepresentatives(page_).Count) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ExtractPowerLevels() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(0, ExtractPowerLevels(page_).Count, "Empty page") + + Call Dev_NewCase("Unlinked nodes") + Dim ks1 As Visio.Shape: Set ks1 = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 30, 30) + Dim ks2 As Visio.Shape: Set ks2 = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 25, 25) + Dim ks3 As Visio.Shape: Set ks3 = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 20, 20) + Dim ks4 As Visio.Shape: Set ks4 = page_.Drop(FindMaster(ThisDocument, MASTER_SCHEMA), 35, 35) + Dim iOperation As Visio.Shape: Set iOperation = page_.Drop(FindMaster(ThisDocument, MASTER_OPERATION), 15, 15) + Dim iLevels As New Scripting.Dictionary + iLevels(ks1.ID) = 1 + iLevels(ks2.ID) = 1 + iLevels(ks3.ID) = 1 + iLevels(ks4.ID) = 1 + iLevels(iOperation.ID) = 1 + Call Dev_ExpectEQ(iLevels, ExtractPowerLevels(page_)) + + Call Dev_NewCase("Valid graph") + Call ks1.AutoConnect(iOperation, visAutoConnectDirNone) + Call ks2.AutoConnect(iOperation, visAutoConnectDirNone) + Call iOperation.AutoConnect(ks3, visAutoConnectDirNone) + Call ks3.AutoConnect(ks4, visAutoConnectDirNone) + Call ks1.AutoConnect(ks4, visAutoConnectDirNone) + iLevels(ks3.ID) = 2 + iLevels(ks4.ID) = 3 + iLevels(iOperation.ID) = 2 + Call Dev_ExpectEQ(iLevels, ExtractPowerLevels(page_)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/s_Operations.cls b/src/s_Operations.cls new file mode 100644 index 0000000..52a0ff1 --- /dev/null +++ b/src/s_Operations.cls @@ -0,0 +1,47 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Operations" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Test block operations ====== +Option Explicit + +' TODO: +' Public Function EnumerateSchemasOn(target As Visio.Page) +' Public Function FixEnumerationOn(target As Visio.Page) +' Public Function ToggleHeadersSelected(iSelected As Visio.Selection) +' Public Function ToggleHeadersAll(iPage As Visio.Page) +' Public Function ToggleHighlight(targets As Visio.Selection) +' Public Function ToggleInherited(targets As Visio.Selection) +' Public Function ToggleMiniatures(target As Visio.Page) +' Public Function ReflectParents(target As Visio.Shape) +' Public Function ToggleThemeColors(iPage As Visio.Page) + +' Public Function ExportExcel(iSource As Visio.Page, iDestination As Excel.Workbook) +' Public Function ExportWord(iSource As Visio.Page, iDestination As Word.Document, iOrder As Collection) + +Private page_ As Visio.Page + +Public Function Setup() + ' Mandatory setup function + Set page_ = ThisDocument.Application.ActivePage +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call ClearAll +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/z_UIMessages.bas b/src/z_UIMessages.bas new file mode 100644 index 0000000..b50e16d --- /dev/null +++ b/src/z_UIMessages.bas @@ -0,0 +1,72 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + EM_SELECT_ELEMENT + EM_SELECT_SCHEMA + EM_MISSING_TEMPLATE + EM_MINIMIZE_CONTAINERS_ONLY + EM_OPERANDS_MISSING + EM_WORD_MISSING_TEMPLATE + + IM_EXPORT_OK + +' QM_CLEAR_ALL +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_SELECT_ELEMENT + Call MsgBox(" ", vbExclamation) + Case EM_SELECT_SCHEMA + Call MsgBox(" ", vbExclamation) + Case EM_MISSING_TEMPLATE + Call MsgBox(" . ", vbExclamation) + Case EM_MINIMIZE_CONTAINERS_ONLY + Call MsgBox(" ", vbExclamation) + Case EM_OPERANDS_MISSING + Call MsgBox(" 1 ", vbExclamation) + Case EM_WORD_MISSING_TEMPLATE + Call MsgBox(" ", vbExclamation) + + Case IM_EXPORT_OK + Call MsgBox(" ", 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_CLEAR_ALL +' answer = MsgBox(" ?", 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..0a3f1f4 --- /dev/null +++ b/src/z_UIRibbon.bas @@ -0,0 +1,26 @@ +Attribute VB_Name = "z_UIRibbon" +Option Explicit + +Public Sub OnAction(iControl As IRibbonControl) + Select Case iControl.ID + Case "ToggleHeaders": Call RunToggleHeaders + Case "ToggleMiniatures": Call RunToggleMiniatures + Case "CycleType": Call RunCycleElementType + Case "ToggleInherited": Call RunToggleInherited + Case "ToggleHighlight": Call RunToggleHighlight + Case "ReflectParents": Call RunReflectParents + Case "FixEnumeration": Call RunFixEnumeration + Case "EnumerateAll": Call RunEnumerateSchemas + + Case "ExportWord": Call RunExportWord + Case "ExportExcel": Call RunExportExcel + Case "ToggleTheme": Call RunToggleColorTheme + Case "GlobalHelp": Call RunHelp + + Case Else: Call CC_DispatchCommand(iControl.ID) + End Select +End Sub + +Public Sub OnUpdateRibbon(iControl As IRibbonControl, ByRef returnedVal) + returnedVal = True +End Sub diff --git a/ui/.rels b/ui/.rels new file mode 100644 index 0000000..dbe39dd --- /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..c50c9b4 --- /dev/null +++ b/ui/customUI1.xml @@ -0,0 +1,125 @@ + + + + + + +