commit b86c5015bc3a09aa66b18cdcceed7cdc5f6ad8f7 Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:05:28 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..aba6674 --- /dev/null +++ b/VBAMake.txt @@ -0,0 +1,40 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home, install_home + +id = Concept-Defs +name = Концепт-Определения +description = Технология анализа нормативных определений +artifact_home = Концепт-Определения +source_home = Concept-Defs +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 <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + +build script\manifest.txt +save_as Карта понятий.vsdm -> 22 Карта понятий.vstm +copy distr\Определения-Excel.xltx -> Определения-Excel.xltx +copy distr\!Руководство пользователя.docx -> !Руководство пользователя.docx + +%% +# === Install section == +# Available commands: +# install LOCAL_ARTIFACT -> [INSTALL_PATH] +# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE] +# run LOCAL_ARTIFACT.bat <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + +install Определения-Excel.xltx +install !Руководство пользователя.docx +install Карта понятий.vsdm + +add_template 22 Карта понятий.vstm +add_template Определения-Excel.xltx -> Технологии\Определения-Excel.xltx \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..88c5fb8 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +1.4.0 diff --git a/distr/!Руководство пользователя.docx b/distr/!Руководство пользователя.docx new file mode 100644 index 0000000..7febf6e 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..02313e8 Binary files /dev/null and b/distr/Определения-Excel.xltx differ diff --git a/distr/Пример входных данных.xlsx b/distr/Пример входных данных.xlsx new file mode 100644 index 0000000..e86be08 Binary files /dev/null and b/distr/Пример входных данных.xlsx differ diff --git a/distr/Руководство по нотации.vsdx b/distr/Руководство по нотации.vsdx new file mode 100644 index 0000000..ec3579a Binary files /dev/null and b/distr/Руководство по нотации.vsdx differ diff --git a/script/manifest.txt b/script/manifest.txt new file mode 100644 index 0000000..ea6ebdc --- /dev/null +++ b/script/manifest.txt @@ -0,0 +1,96 @@ +# == 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_Python.bas + ex_WinAPI.bas + + API_Python.cls + API_VsoWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +excel + API_XLRecordsWrapper.cls + +utility + ex_VBA.bas + ex_Collection.bas + ex_Version.bas + + API_DistrManifest.cls + API_Config.cls + API_JSON.cls + CDS_Factorizator.cls + CDS_Edge.cls + CDS_Node.cls + CDS_Graph.cls + API_StrongComponents.cls + +visio + API_UndoWrapper.cls + z_VsoGraph.bas + z_VsoUtilities.bas + z_CCVsoExtension.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 + NewConcept.frm + GridDlg.frm + + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + z_UIRibbon.bas + z_UIMessages.bas + + RankGrid.cls + TermItem.cls + Exporter.cls + ComparatorExporter.cls + + s_RankGrid.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 : MSForms +global : Shell32 +global : Excel \ No newline at end of file diff --git a/skeleton/Карта понятий.vsdm b/skeleton/Карта понятий.vsdm new file mode 100644 index 0000000..5c2e2aa Binary files /dev/null and b/skeleton/Карта понятий.vsdm differ diff --git a/src/ComparatorExporter.cls b/src/ComparatorExporter.cls new file mode 100644 index 0000000..ce9f32e --- /dev/null +++ b/src/ComparatorExporter.cls @@ -0,0 +1,83 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ComparatorExporter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private outWB_ As Excel.Workbook +Private outCmp_ As Excel.Worksheet + +Private src1_ As Visio.Page +Private src2_ As Visio.Page + +Private sourceNames_ As New Collection + +Public Function Init(iDestination As Excel.Workbook) + Set outWB_ = iDestination +End Function + +Public Function RunCompare(src1 As Visio.Page, src2 As Visio.Page) + Dim out1_ As New API_XLRecordsWrapper: Call out1_.Init(outWB_.Sheets(1)) + Dim out2_ As New API_XLRecordsWrapper: Call out2_.Init(outWB_.Sheets(2)) + Dim items1 As Collection: Set items1 = ScanDataFrom(src1, out1_) + Dim items2 As Collection: Set items2 = ScanDataFrom(src2, out2_) + Call OutputComparison(items1, items2) +End Function + +' ============= +Private Function ScanDataFrom(src As Visio.Page, ByRef out As API_XLRecordsWrapper) As Collection + Set ScanDataFrom = New Collection + + Dim aShape As Visio.Shape + For Each aShape In src.Shapes + If aShape.OneD Then _ + GoTo NEXT_SHAPE + + Dim theType As ShapeType: theType = GetShapeType(aShape) + If theType = STYPE_GRID Or theType = STYPE_UNKNOWN Then _ + GoTo NEXT_SHAPE + + out.Field(XL_TS_ID) = aShape.ID + + If theType = STYPE_DERIVED Then + out.Field(XL_TS_NAME) = VBA.Trim(aShape.Shapes(S_D_TERM).Text) + out.Field(XL_TS_DEFINITION) = aShape.Shapes(S_D_DEFINITION).Text + out.Field(XL_TS_DEFINITION).WrapText = False + Else + out.Field(XL_TS_NAME) = Trim(aShape.Text) + End If + + Call SafeAddToCollection(out.Field(XL_TS_NAME), out.Field(XL_TS_NAME), ScanDataFrom) + Call out.MoveNext +NEXT_SHAPE: + Next aShape +End Function + +Private Function OutputComparison(src1 As Collection, src2 As Collection) + Dim out1_ As New API_XLRecordsWrapper: Call out1_.Init(outWB_.Sheets(3)) + Dim out2_ As New API_XLRecordsWrapper: Call out2_.Init(outWB_.Sheets(3)) + Dim outCommon_ As New API_XLRecordsWrapper: Call outCommon_.Init(outWB_.Sheets(3)) + + Dim strItem As Variant + For Each strItem In src1 + If InCollection(CStr(strItem), src2) Then + outCommon_.Field(XL_COMP_SHARED) = strItem + Call outCommon_.MoveNext + Else + out1_.Field(XL_COMP_1ST) = strItem + Call out1_.MoveNext + End If + Next strItem + + For Each strItem In src2 + If Not InCollection(CStr(strItem), src1) Then + out2_.Field(XL_COMP_2ND) = strItem + Call out2_.MoveNext + End If + Next strItem +End Function diff --git a/src/Declarations.bas b/src/Declarations.bas new file mode 100644 index 0000000..9885038 --- /dev/null +++ b/src/Declarations.bas @@ -0,0 +1,150 @@ +Attribute VB_Name = "Declarations" +Option Explicit + +Public Const APP_HELP = "\\fs1.concept.ru\projects\10 \01 \-\! .docx" + +Public Const MASTER_BASIC = " " +Public Const MASTER_DERIVED = "" +Public Const MASTER_LEVEL = " " + +Public Const SHAPE_DERVIED = "STermName" + +Public Const PREFIX_GRID = "SLevel" +Public Const MASK_LEVEL = "SLevel*" + +Public Const COLOR_MENTION = "RGB(0,176,240)" +Public Const COLOR_INVALID = "RGB(192,0,0)" + +Public Const RANK_MAX = 15 +Public Const RANK_UNREACHABLE = -1 + +Public Const SHAPE_BASIC = "SBasic" +Public Const SHAPE_DERIVED = "SDefinedNotion" +Public Const SHAPE_BLOCK = "SBlock" +Public Const SHAPE_CONNECTOR = "SConnector" +Public Const SHAPE_LEVEL = "SLevel" + +Public Const VSO_CELL_LTYPE = "User.LinkType" +Public Const VSO_CELL_SOLID = "User.IsSolid" +Public Const VSO_CELL_BOLD = "User.IsBold" +Public Const VSO_BASIC_LTYPE = "User.Type" + +Public Const V_GAP = 6.5 / 28.35 ' cm +Public Const H_GAP = 3 / 28.35 ' cm +Public Const GRID_X_MARGIN = 40 ' mm + +Public Const MOST_LEFT = -99999 + +Public Const BASE_START = 5 +Public Const BASIC_COLOMNS = 5 +Public Const DERIVED_ROWS = 5 + +Public Enum ShapeType + STYPE_UNKNOWN = 0 + STYPE_BASIC = 1 + STYPE_TODO = 2 + STYPE_ANNOUNCED = 3 + STYPE_UNCLEAR = 4 + STYPE_DERIVED = 5 + STYPE_BLOCK = 6 + STYPE_LINK = 7 + STYPE_GRID = 8 +End Enum + +Public Enum LinkType + LT_DEFINE = 1 + LT_CIRCLE = 2 + LT_SYNON = 3 + LT_OMON = 4 + LT_CONSISTS = 5 +End Enum + +Public Enum DerivedStructure + S_D_TERM = 1 + S_D_SOURCE = 2 + S_D_DEFINITION = 3 +End Enum + +' -------- Excel ------------- +Public Const TEMPLATE_PREFIX = "" +Public Const SERVER_TEMPLATES = "\\fs1.concept.ru\projects\10 \01 \-" + +Public Const XL_TEMPLATE_NAME = "-Excel.xltx" + +Public Const XL_SHEET_SHAPES = "" +Public Const XL_SHEET_LINKS = "" +Public Const XL_SHEET_MENTIONS = "" +Public Const XL_SHEET_CYCLES = "" + +Public Enum ThesaurusStruct + XL_TS_ID = 1 + XL_TS_NAME = 2 + XL_TS_DEFINITION = 3 +End Enum + +Public Enum CompareStruct + XL_COMP_1ST = 1 + XL_COMP_2ND = 2 + XL_COMP_SHARED = 3 +End Enum + +Public Enum FullExportStruct + XL_COL_ID = 1 + XL_COL_TYPE = 2 + XL_COL_TERMNAME = 3 + XL_COL_DEFINITION = 4 + XL_COL_SOURCE = 5 + XL_COL_PARENT = 6 + XL_COL_COPY = 7 + XL_COL_PINX = 8 + XL_COL_PINY = 9 + XL_COL_WIDTH = 10 + XL_COL_HEIGHT = 11 + XL_COL_LINECOLOR = 12 + XL_COL_TEXTCOLOR = 13 +End Enum + +Public Enum MentionsStruct + XL_MENT_ID = 1 + XL_MENT_START = 2 + XL_MENT_FINISH = 3 + XL_MENT_TEXT = 4 + XL_MENT_COLOR = 5 + XL_MENT_STYLE = 6 +End Enum + +Public Function GetExportTemplate(sFile$) As String + Dim fso As New Scripting.FileSystemObject + + GetExportTemplate = SERVER_TEMPLATES & "\" & sFile + If fso.FileExists(GetExportTemplate) Then _ + Exit Function + + GetExportTemplate = ThisDocument.Path & sFile + If fso.FileExists(GetExportTemplate) Then _ + Exit Function + + GetExportTemplate = TEMPLATE_PREFIX & "\" & sFile +End Function + +Public Function GetShapeType(target As Visio.Shape) As ShapeType + If target.MasterShape Is Nothing Then + GetShapeType = STYPE_UNKNOWN + Exit Function + End If + + Select Case (target.MasterShape.Name) + Case SHAPE_BASIC: GetShapeType = target.CellsU(VSO_BASIC_LTYPE) + Case SHAPE_DERIVED: GetShapeType = STYPE_DERIVED + Case SHAPE_BLOCK: GetShapeType = STYPE_BLOCK + Case SHAPE_CONNECTOR: GetShapeType = STYPE_LINK + Case SHAPE_LEVEL: GetShapeType = STYPE_GRID + Case Else: GetShapeType = STYPE_UNKNOWN + End Select +End Function + +Public Function IsShapeDuplicate(target As Visio.Shape) As Boolean + If CellsExists(target, VSO_CELL_SOLID) Then _ + IsShapeDuplicate = IIf(target.CellsU(VSO_CELL_SOLID), False, True) +End Function + diff --git a/src/DevHelper.bas b/src/DevHelper.bas new file mode 100644 index 0000000..be44592 --- /dev/null +++ b/src/DevHelper.bas @@ -0,0 +1,22 @@ +Attribute VB_Name = "DevHelper" +Option Private Module +Option Explicit + +Public Function Dev_PrepareSkeleton() + ' Do nothing + Call ClearAllExceptGrid(ActivePage) +End Function + +Public Function Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_RankGrid" + Dim sTest$: sTest = "t_ChangeWidth" + 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_RankGrid": Set Dev_GetTestSuite = New s_RankGrid + End Select +End Function diff --git a/src/Exporter.cls b/src/Exporter.cls new file mode 100644 index 0000000..14ef54a --- /dev/null +++ b/src/Exporter.cls @@ -0,0 +1,259 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Exporter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ==== Excel export manager ========= +Option Explicit + +Private links_ As API_XLRecordsWrapper +Private shapes_ As API_XLRecordsWrapper +Private mentions_ As API_XLRecordsWrapper +Private cycles_ As API_XLRecordsWrapper +Private graph_ As CDS_Graph +Private terms_ As Scripting.Dictionary +Private mutualEdges_ As Scripting.Dictionary +Private thePage_ As Visio.Page + +Public Function Init(iOut As Excel.Workbook) + Set links_ = New API_XLRecordsWrapper: Call links_.Init(iOut.Sheets(XL_SHEET_LINKS)) + Set shapes_ = New API_XLRecordsWrapper: Call shapes_.Init(iOut.Sheets(XL_SHEET_SHAPES)) + Set mentions_ = New API_XLRecordsWrapper: Call mentions_.Init(iOut.Sheets(XL_SHEET_MENTIONS)) + Set cycles_ = New API_XLRecordsWrapper: Call cycles_.Init(iOut.Sheets(XL_SHEET_CYCLES), 1) + Set graph_ = New CDS_Graph + Set terms_ = New Scripting.Dictionary + Set mutualEdges_ = New Scripting.Dictionary +End Function + +Public Function ScanDataFrom(iSource As Visio.Page) + Set thePage_ = iSource + + Call CSE_ProgressBar.Init(" ", sHeader:=" ", maxVal:=2 * thePage_.Shapes.Count) + Call CSE_ProgressBar.ShowModeless + + Call ScanShapes + Call ProcessDuplicates + Call OutputCycles + + Unload CSE_ProgressBar +End Function + +' ======== +Private Function ScanShapes() + Dim aShape As Visio.Shape + For Each aShape In thePage_.Shapes + If aShape.OneD Then + Call ScanLink(aShape) + Else + Call ScanTerm(aShape) + End If + Call CSE_ProgressBar.IncrementA + Next aShape +End Function + +Private Function ProcessDuplicates() + Dim aShape As Visio.Shape + For Each aShape In thePage_.Shapes + If aShape.OneD Or Not aShape.CellExistsU(VSO_CELL_SOLID, visExistsAnywhere) Then _ + GoTo NEXT_SHAPE + If aShape.CellsU(VSO_CELL_SOLID) Then _ + GoTo NEXT_SHAPE + + Dim sText$ + If GetShapeType(aShape) = STYPE_DERIVED Then + sText = aShape.Shapes(S_D_DEFINITION).Text + Else + sText = aShape.Text + End If + If Not terms_.Exists(sText) Then _ + GoTo NEXT_SHAPE + + Dim originalID&: originalID = terms_(sText) + If originalID = aShape.ID Then _ + GoTo NEXT_SHAPE + + Dim edge1 As CDS_Edge: Set edge1 = graph_.AddEdge(aShape.ID, originalID) + If Not edge1 Is Nothing Then _ + Call mutualEdges_.Add(edge1.ID, 0) + Dim edge2 As CDS_Edge: Set edge2 = graph_.AddEdge(originalID, aShape.ID) + If Not edge2 Is Nothing Then _ + Call mutualEdges_.Add(edge2.ID, 0) + +NEXT_SHAPE: + Call CSE_ProgressBar.IncrementA + Next aShape +End Function + +Private Function OutputCycles() + Dim scc As New API_StrongComponents + Dim components As Collection: Set components = scc.GetComponents(graph_) + Dim vComponent As Scripting.Dictionary + Dim nShapeID As Variant + For Each vComponent In components + If CheckCycle(vComponent) Then + Dim nColumn&: nColumn = 1 + For Each nShapeID In vComponent + Dim aShape As Visio.Shape: Set aShape = thePage_.Shapes.ItemFromID(nShapeID) + If aShape.Shapes.Count = 3 Then + cycles_.Field(nColumn) = aShape.Shapes(S_D_TERM).Text & " (" & nShapeID & ")" + Else + cycles_.Field(nColumn) = aShape.Text & " (" & nShapeID & ")" + End If + nColumn = nColumn + 1 + Next nShapeID + Call cycles_.MoveNext + End If + Next vComponent +End Function + +' ============ +Private Function ScanLink(target As Visio.Shape) + If target.Connects.Count <> 2 Then _ + Exit Function + + Dim nSource$: nSource = target.Connects(1).ToSheet.ID + Dim nDest$: nDest = target.Connects(2).ToSheet.ID + + links_.Field(1) = target.ID + links_.Field(2) = nSource + links_.Field(3) = nDest + + If GetShapeType(target) = STYPE_LINK Then + Dim tLink&: tLink = target.CellsU(VSO_CELL_LTYPE) + links_.Field(4) = tLink + links_.Field(5) = IIf(target.CellsU(VSO_CELL_SOLID), 0, 1) + links_.Field(6) = IIf(target.CellsU(VSO_CELL_BOLD), 1, 0) + + If tLink <> LT_OMON And tLink <> LT_CONSISTS Then + Call graph_.AddEdge(nSource, nDest) + If tLink = LT_SYNON Then + Dim newEdge As CDS_Edge: Set newEdge = graph_.AddEdge(nDest, nSource) + If Not newEdge Is Nothing Then + mutualEdges_.Item(newEdge.ID) = 0 + mutualEdges_.Item(newEdge.Reversed.ID) = 0 + End If + End If + End If + End If + + Call links_.MoveNext +End Function + +Private Function ScanTerm(target As Visio.Shape) + Dim theType As ShapeType: theType = GetShapeType(target) + If theType = STYPE_GRID Then _ + Exit Function + + Call graph_.AddNode(target.ID) + + shapes_.Field(XL_COL_ID) = target.ID + shapes_.Field(XL_COL_TYPE) = theType + shapes_.Field(XL_COL_PINX) = target.CellsU("PinX").result(visMillimeters) + shapes_.Field(XL_COL_PINY) = target.CellsU("PinY").result(visMillimeters) + shapes_.Field(XL_COL_WIDTH) = target.CellsU("Width").result(visMillimeters) + shapes_.Field(XL_COL_HEIGHT) = target.CellsU("Height").result(visMillimeters) + shapes_.Field(XL_COL_LINECOLOR) = target.CellsU("LineColor") + shapes_.Field(XL_COL_TEXTCOLOR) = target.CellsU("Char.Color") + + If theType = STYPE_DERIVED Then + shapes_.Field(XL_COL_TERMNAME) = target.Shapes(S_D_TERM).Text + shapes_.Field(XL_COL_DEFINITION) = target.Shapes(S_D_DEFINITION).Text + shapes_.Field(XL_COL_SOURCE) = target.Shapes(S_D_SOURCE).Text + + Call ScanMentions(target.ID, target.Shapes(S_D_DEFINITION)) + Else + shapes_.Field(XL_COL_TERMNAME) = target.Text + End If + + Dim parent As Visio.Shape: Set parent = GetContainingShape(target) + If Not parent Is Nothing Then + shapes_.Field(XL_COL_PARENT) = parent.ID + End If + + If theType <= STYPE_DERIVED And theType >= STYPE_BASIC Then + Dim isCopy&: isCopy = IIf(target.CellsU(VSO_CELL_SOLID), 0, 1) + shapes_.Field(XL_COL_COPY) = isCopy + If Not isCopy Then _ + Call terms_.Add(shapes_.Field(XL_COL_TERMNAME), target.ID) + End If + + Call shapes_.MoveNext +End Function + +Private Function ScanMentions(nID&, target As Visio.Shape) + Dim sText$: sText = target.Text + + Dim nSection&: nSection = 0 + Dim nStart&: nStart = 0 + Dim nFinish&: nFinish = 1 + Dim nLast&: nLast = target.Characters.End + + Dim iChars As Visio.Characters: Set iChars = target.Characters + iChars.Begin = nStart + iChars.End = nFinish + Do While nSection < target.RowCount(visSectionCharacter) - 1 + Do While nSection = iChars.CharPropsRow(visBiasRight) And nFinish <> nLast + nFinish = nFinish + 1 + iChars.End = nFinish + Loop + nFinish = nFinish - 1 + + Dim sColor$: sColor = target.CellsSRC(visSectionCharacter, nSection, visCharacterColor) + Dim sStyle$: sStyle = target.CellsSRC(visSectionCharacter, nSection, visCharacterStyle) + Dim sItem$: sItem = FixShapeText(VBA.Mid(sText, nStart + 1, nFinish - nStart)) + If IsNotEmpty(sItem) And (Not IsDefaultColor(sColor) Or Not IsDefaultStyle(sStyle)) Then + mentions_.Field(XL_MENT_ID) = nID + mentions_.Field(XL_MENT_TEXT) = sItem + mentions_.Field(XL_MENT_START) = nStart + mentions_.Field(XL_MENT_FINISH) = nFinish + mentions_.Field(XL_MENT_COLOR) = sColor + mentions_.Field(XL_MENT_STYLE) = sStyle + + Call mentions_.MoveNext + End If + + iChars.Begin = nFinish + nStart = nFinish + nSection = nSection + 1 + Loop +End Function + +Private Function FixShapeText(sText$) As String + FixShapeText = Trim(sText) + FixShapeText = Replace(FixShapeText, Chr(9), " ") + FixShapeText = Replace(FixShapeText, Chr(160), " ") + FixShapeText = Trim(FixShapeText) +End Function + +Private Function IsNotEmpty(sText$) As Boolean + IsNotEmpty = sText <> "" And Not sText Like "[,.!?:;]" +End Function + +Private Function IsDefaultColor(sColor$) As Boolean + IsDefaultColor = sColor = "0" Or sColor = "30" +End Function + +Private Function IsDefaultStyle(sStyle$) As Boolean + IsDefaultStyle = sStyle = "0" +End Function + +Private Function CheckCycle(target As Scripting.Dictionary) As Boolean + If target.Count < 2 Then + CheckCycle = True + Exit Function + End If + + Dim anEdge As CDS_Edge + For Each anEdge In graph_.FilterInternalEdges(target) + If Not mutualEdges_.Exists(anEdge.ID) Then + CheckCycle = True + Exit Function + End If + Next anEdge + CheckCycle = False +End Function + diff --git a/src/GridDlg.frm b/src/GridDlg.frm new file mode 100644 index 0000000..f923a1c --- /dev/null +++ b/src/GridDlg.frm @@ -0,0 +1,45 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} GridDlg + Caption = " " + ClientHeight = 2205 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 3540 + OleObjectBlob = "GridDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "GridDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public isCancelled_ As Boolean + +Private Sub UserForm_Initialize() + isCancelled_ = True +End Sub + +Private Sub OkBtn_Click() + isCancelled_ = False + Me.Hide +End Sub + +Private Sub CancelBtn_Click() + isCancelled_ = True + Me.Hide +End Sub + +Public Property Get LevelCount() As Long + LevelCount = Me.CountTB.Value +End Property + +Public Property Get LevelHeight() As Long + LevelHeight = Me.HeightTB.Value +End Property + +Public Property Get FirstGap() As Long + FirstGap = Me.FirstLevelTB.Value +End Property + diff --git a/src/GridDlg.frx b/src/GridDlg.frx new file mode 100644 index 0000000..f476358 Binary files /dev/null and b/src/GridDlg.frx differ diff --git a/src/Main.bas b/src/Main.bas new file mode 100644 index 0000000..877b740 --- /dev/null +++ b/src/Main.bas @@ -0,0 +1,323 @@ +Attribute VB_Name = "Main" +' ============= ========== +Option Explicit + +Public Const PRODUCT_VERSION = "1.3.0" +Public Const PRODUCT_NAME = "Concept-Defs" + +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 FixOldShapes() + Dim thePage As Visio.Page: Set thePage = ActivePage + Dim vsoShape As Visio.Shape + Dim i&: i = 1 + For i = 1 To thePage.Shapes.Count Step 1 + Set vsoShape = thePage.Shapes(i) + If GetShapeType(vsoShape) = STYPE_DERIVED Then + vsoShape.Shapes(2).CellsU("Width").Formula = "20mm" + vsoShape.Shapes(3).CellsU("Width").FormulaU = "=Sheet." & CStr(vsoShape.ID) & "!Width - Sheet." & CStr(vsoShape.Shapes(2).ID) & "!Width" + End If + Next i +End Sub + +Public Sub RunImportExcel() + Dim theData As Collection: Set theData = PromptExcelData + If theData Is Nothing Then _ + Exit Sub + + Dim vsoAppl As New API_VsoWrapper: Call vsoAppl.SetDocument(ThisDocument) + Call vsoAppl.PauseUI + Call GlobalUndo.BeginScope(" ") + + Call CSE_ProgressBar.Init(" ", sHeader:=" ...", maxVal:=theData.Count) + Call CSE_ProgressBar.ShowModeless + + Dim baseCount&, termCount& + Call BuildFromTerms(theData, baseCount, termCount) + + Call Unload(CSE_ProgressBar) + + Call GlobalUndo.EndScope + Call vsoAppl.ResumeUI + + Call UserInteraction.ShowMessage(IM_GENEARION_COMPLETE, baseCount, termCount) +End Sub + +Public Sub RunAddNotion() + Call NewConcept.Show + If NewConcept.isCancelled_ = True Then _ + Exit Sub + If IsNumeric(NewConcept.RankInput.Value) = False Then + Call UserInteraction.ShowMessage(EM_INVALID_LEVEL) + Exit Sub + End If + + Dim term As TermItem: Set term = NewConcept.GetTerm + Dim iRank%: iRank = NewConcept.RankInput.Value + Call Unload(NewConcept) + + Call GlobalUndo.BeginScope(" ") + + Call AddTermTo(term, ActivePage, iRank) + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunGridPlus10() + Call GlobalUndo.BeginScope(" ") + + If Not ActiveGrid.IncrementWidth(Visio.Application.ConvertResult(100, visMillimeters, visInches)) Then _ + Call UIShowMessage(EM_INVALID_WIDTH) + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunGridMinus10() + Call GlobalUndo.BeginScope(" ") + + If Not ActiveGrid.IncrementWidth(Visio.Application.ConvertResult(-100, visMillimeters, visInches)) Then _ + Call UIShowMessage(EM_INVALID_WIDTH) + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunGridChange() + Dim sDiff$: sDiff = UserInteraction.PromptInput(" ", " ", 100) + If Not IsNumeric(sDiff) Then _ + Exit Sub + Dim mmDiff&: mmDiff = CLng(sDiff) + + Call GlobalUndo.BeginScope(" ") + + If Not ActiveGrid.IncrementWidth(Visio.Application.ConvertResult(mmDiff, visMillimeters, visInches)) Then _ + Call UIShowMessage(EM_INVALID_WIDTH) + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunMoveUp() +Attribute RunMoveUp.VB_ProcData.VB_Invoke_Func = "q" + Dim iSelected As Collection: Set iSelected = GetSelectedItems + If iSelected.Count = 0 Then + Call UserInteraction.ShowMessage(EM_EMPTY_SELECTION) + Exit Sub + End If + + ThisDocument.DiagramServicesEnabled = visServiceStructureBasic + Call GlobalUndo.BeginScope(" ") + + Dim rGrid As RankGrid: Set rGrid = ActiveGrid + Dim vsoShape As Visio.Shape + For Each vsoShape In iSelected + Call rGrid.MoveUp(vsoShape) + Next vsoShape + + Call GlobalUndo.EndScope + ThisDocument.DiagramServicesEnabled = 0 +End Sub + +Public Sub RunMoveDown() +Attribute RunMoveDown.VB_ProcData.VB_Invoke_Func = "e" + Dim iSelected As Collection: Set iSelected = GetSelectedItems + If iSelected.Count = 0 Then + Call UserInteraction.ShowMessage(EM_EMPTY_SELECTION) + Exit Sub + End If + + ThisDocument.DiagramServicesEnabled = visServiceStructureBasic + Call GlobalUndo.BeginScope(" ") + + Dim rGrid As RankGrid: Set rGrid = ActiveGrid + Dim nOldSize%: nOldSize = rGrid.Size + Dim vsoShape As Visio.Shape + For Each vsoShape In iSelected + Call rGrid.MoveDown(vsoShape) + Next vsoShape + + If rGrid.Size <> nOldSize Then _ + Call VsoSelectShapes(iSelected, ActivePage) + + Call GlobalUndo.EndScope + ThisDocument.DiagramServicesEnabled = 0 +End Sub + +Public Sub RunMoveToX() +Attribute RunMoveToX.VB_ProcData.VB_Invoke_Func = "w" + Dim iSelected As Collection: Set iSelected = GetSelectedItems + If iSelected.Count = 0 Then + Call UserInteraction.ShowMessage(EM_EMPTY_SELECTION) + Exit Sub + End If + + Dim sRank$: sRank = UserInteraction.PromptInput(" ", " ", 1) + If Not IsNumeric(sRank) Then _ + Exit Sub + Dim iRank%: iRank = VBA.Int(sRank) + If iRank > RANK_MAX Or iRank < 0 Then + Call UserInteraction.ShowMessage(EM_INVALID_LEVEL) + Exit Sub + End If + + ThisDocument.DiagramServicesEnabled = visServiceStructureBasic + Call GlobalUndo.BeginScope("") + + Dim rGrid As RankGrid: Set rGrid = ActiveGrid + Dim nOldSize%: nOldSize = rGrid.Size + Dim vsoShape As Visio.Shape + For Each vsoShape In iSelected + Call rGrid.MoveToRank(vsoShape, iRank) + Next vsoShape + + If rGrid.Size <> nOldSize Then _ + Call VsoSelectShapes(iSelected, ActivePage) + + Call GlobalUndo.EndScope + ThisDocument.DiagramServicesEnabled = 0 +End Sub + +Public Sub RunExportExcel() + Call Export2ExcelFrom(ActivePage) + Call UserInteraction.ShowMessage(IM_EXPORT_XL_COMPLETE) +End Sub + +Public Sub RunCompare() + Dim sFileName$: sFileName = UserInteraction.PromptFileFilter( _ + sInitialPath:=ThisDocument.Path, _ + sDescription:="Visio file", _ + sFilter:="*.vsd*", _ + bNewApplication:=True) + If sFileName = vbNullString Then _ + Exit Sub + + Dim thisDoc As Visio.Document: Set thisDoc = ActiveDocument + Dim wrap As New API_VsoWrapper + Call wrap.CreateApplication + If wrap.OpenDocument(sFileName, nOpenFlags:=visOpenRO + visOpenMacrosDisabled) Is Nothing Then _ + Exit Sub + + Dim res As Boolean: res = ExportComparison(thisDoc, wrap.Document) + Call wrap.ReleaseDocument + + If res Then _ + Call UserInteraction.ShowMessage(IM_EXPORT_DIFF_COMPLETE) +End Sub + +Public Sub RunCleanUp() + Call GlobalUndo.BeginScope("") + + Call ClearAllExceptGrid(Visio.ActivePage) + Visio.ActiveWindow.ViewFit = visFitPage + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunAddGrid() + Call GridDlg.Show + If GridDlg.isCancelled_ = True Then _ + Exit Sub + + Dim nCount%: nCount = GridDlg.LevelCount + Dim dTopMargin As Double: dTopMargin = Visio.Application.ConvertResult(GridDlg.FirstGap, visMillimeters, visInches) + Dim dHeight As Double: dHeight = Visio.Application.ConvertResult(GridDlg.LevelHeight, visMillimeters, visInches) + Dim dLeftMargin As Double: dLeftMargin = Visio.Application.ConvertResult(GRID_X_MARGIN, visMillimeters, visInches) + Dim dWidth As Double: dWidth = ActivePage.PageSheet.CellsU("PageWidth") - dLeftMargin + Unload GridDlg + + Call GlobalUndo.BeginScope(" ") + + Call ActiveGrid.CreateGrid(nCount, dHeight:=dHeight, dWidth:=dWidth, dTopMargin:=dTopMargin, dLeftMargin:=dLeftMargin) + + Call GlobalUndo.EndScope + +End Sub + +Public Sub RunDeleteGrid() + Call GlobalUndo.BeginScope(" ") + + Call ActiveGrid.DeleteGrid + + Call GlobalUndo.EndScope +End Sub + +Public Sub RunHelp() + Dim objWord As Object: Set objWord = CreateObject("Word.Application") + Dim objDoc As Object: Set objDoc = objWord.Documents.Open(APP_HELP, ReadOnly:=True) + With objWord + .Visible = True + .ActiveWindow.View.ReadingLayout = False + Call .Activate + End With +End Sub + +' ===== Context menu API ======== +Public Function Automarkdown(target As Visio.Shape) + Dim iPage As Visio.Page: Set iPage = target.parent + Dim iTerms As Scripting.Dictionary: Set iTerms = ScanAllTerms(iPage) + Dim iDefinition As Visio.Shape: Set iDefinition = target.Shapes(S_D_DEFINITION) + + Call GlobalUndo.BeginScope("") + + Dim sText$: sText = VBA.LCase(iDefinition.Text) + + Dim sTerm As Variant + Dim iFoundRange As Variant + Dim nStart&, nEnd& + Dim iSource As Visio.Shape + For Each sTerm In iTerms.Keys + On Error GoTo SAFE_EXIT + iFoundRange = AccessPython.CallFunction(PY_MODULE_TEXT, "find_substr", Array(sText, CStr(sTerm))) + If VarType(iFoundRange) = vbString Then + Call UserInteraction.ShowMessage(EM_PYTHON_ERROR, iFoundRange) + GoTo SAFE_EXIT + End If + On Error GoTo 0 + nStart = iFoundRange(0) + nEnd = iFoundRange(1) + If nStart = nEnd Then _ + GoTo NEXT_TERM + + Set iSource = iTerms(sTerm) + If iSource.ID = target.ID Then + Call VsoApplyColorTo(iDefinition, nStart, nEnd, COLOR_INVALID) + Else + Call VsoApplyColorTo(iDefinition, nStart, nEnd, COLOR_MENTION) + If Not VsoIsConnected(iSource, target) Then _ + Call iSource.AutoConnect(target, visAutoConnectDirNone) + End If + +NEXT_TERM: + Next sTerm + +SAFE_EXIT: + Call GlobalUndo.EndScope +End Function + +' ======= +Private Function GetSelectedItems() As Collection ' of Visio.Shape + Dim iShapes As New Collection + + Dim iSelected As Visio.Selection: Set iSelected = ActiveWindow.Selection + Dim vsoShape As Visio.Shape + For Each vsoShape In iSelected + If Not vsoShape.OneD Then _ + If GetShapeType(vsoShape) <> STYPE_GRID Then _ + Call iShapes.Add(vsoShape) +NEXT_SHAPE: + Next vsoShape + + Set GetSelectedItems = iShapes +End Function + +Private Function ActiveGrid() As RankGrid + Set ActiveGrid = New RankGrid + Call ActiveGrid.Init(ActivePage) +End Function diff --git a/src/MainImpl.bas b/src/MainImpl.bas new file mode 100644 index 0000000..ef1cd3e --- /dev/null +++ b/src/MainImpl.bas @@ -0,0 +1,296 @@ +Attribute VB_Name = "MainImpl" +Option Explicit + +Public Function ClearAllExceptGrid(target As Visio.Page) + Dim vsoShape As Visio.Shape + Dim i&: i = 1 + Do While i <= target.Shapes.Count + Set vsoShape = target.Shapes(i) + If GetShapeType(vsoShape) = STYPE_GRID Then + i = i + 1 + GoTo Continue + End If + + Call vsoShape.Delete + i = 1 +Continue: + Loop +End Function + +Public Function CreateItemShape(term As TermItem, target As Visio.Page) As Visio.Shape + Dim res As Visio.Shape + If term.Basic Then + Set res = CreateShape(MASTER_BASIC, target) + res.Characters.Text = term.name_ + Else + Set res = CreateShape(MASTER_DERIVED, target) + res.Shapes(S_D_TERM).Text = term.name_ + res.Shapes(S_D_SOURCE).Text = term.source_ + res.Shapes(S_D_DEFINITION).Text = term.definition_ + + If InStr(term.definition_, Chr(13)) = 0 Then + res.Shapes(S_D_DEFINITION).CellsU("Width").FormulaU = "=MAX(50mm, TEXTWIDTH(TheText)*Char.Size*1.4/Height + 0.2in)" + res.CellsU("Width") = res.Shapes(S_D_SOURCE).CellsU("Width") + res.Shapes(S_D_DEFINITION).CellsU("Width") + res.Shapes(S_D_DEFINITION).CellsU("Width").FormulaU = "=Sheet." & CStr(res.ID) & "!Width - Sheet." & CStr(res.Shapes(S_D_SOURCE).ID) & "!Width" + End If + End If + Set CreateItemShape = res +End Function + +Public Function CreateShape(sMaster$, iDestination As Visio.Page) As Visio.Shape + Set CreateShape = iDestination.Drop(FindMaster(iDestination.Document, sMaster), 0, 0) +End Function + +Public Function AddTermTo(target As TermItem, iDestination As Visio.Page, iRank%) + Dim itemShape As Visio.Shape: Set itemShape = CreateItemShape(target, iDestination) + Dim rGrid As New RankGrid: Call rGrid.Init(iDestination) + + Dim baseX As Double: baseX = GetMostRightPos + If baseX = MOST_LEFT Then + baseX = iDestination.Shapes("SLevel1").CellsU("pinx") - iDestination.Shapes("SLevel1").CellsU("width") / 2# + End If + itemShape.CellsU("PinX") = baseX + itemShape.CellsU("Width") / 2# + + Call rGrid.MoveToRank(itemShape, iRank) + Call CenterScreenOnShape(itemShape) +End Function + +Public Function PromptExcelData() As Collection + Dim sFileName$: sFileName = UserInteraction.PromptFileFilter( _ + sInitialPath:=ThisDocument.Path, _ + sDescription:="Excel file", _ + sFilter:="*.xls*;*.csv", _ + bNewApplication:=True) + If sFileName = "" Then _ + Exit Function + + Dim wrap As New API_XLWrapper + If wrap.OpenDocument(sFileName) Is Nothing Then _ + Exit Function + + Dim theData As Collection + Set theData = ScanExcel(wrap.Document.Worksheets(1)) + If theData Is Nothing Then + Call UserInteraction.ShowMessage(EM_INVALID_FILE_FORMAT) + Exit Function + End If + + Call wrap.ReleaseDocument + Set PromptExcelData = theData +End Function + +Public Function Export2ExcelFrom(target As Visio.Page) + Dim templatePath$: templatePath = GetExportTemplate(XL_TEMPLATE_NAME) + Dim wrapper As New API_XLWrapper + Dim wb As Excel.Workbook: Set wb = wrapper.NewDocument(templatePath) + If wb Is Nothing Then _ + Exit Function + + If templatePath = vbNullString Then + Call UserInteraction.ShowMessage(EM_TEMPLATE_MISSING) + Call wb.Sheets.Add + Call wb.Sheets.Add + Call wb.Sheets.Add + wb.Sheets(1).Name = XL_SHEET_SHAPES + wb.Sheets(2).Name = XL_SHEET_LINKS + wb.Sheets(3).Name = XL_SHEET_MENTIONS + wb.Sheets(4).Name = XL_SHEET_CYCLES + End If + + Call wrapper.PauseUI + + Dim helper As New Exporter: Call helper.Init(wb) + Call helper.ScanDataFrom(target) + + Call wrapper.ResumeUI + Call Unload(CSE_ProgressBar) +End Function + +Public Function ExportComparison(iSource As Visio.Document, target As Visio.Document) As Boolean + ExportComparison = False + + Dim xlAppl As New API_XLWrapper + Dim outWB As Excel.Workbook: Set outWB = xlAppl.NewDocument + If outWB Is Nothing Then _ + Exit Function + + Call xlAppl.PauseUI + + Call PrepareCompareOutput(outWB) + Dim Exporter As New ComparatorExporter: Call Exporter.Init(outWB) + Call Exporter.RunCompare(iSource.Pages(1), target.Pages(1)) + Call FinalizeCompare(outWB) + + Call xlAppl.ResumeUI + + ExportComparison = True +End Function + +Public Function BuildFromTerms(theData As Collection, ByRef baseCount&, ByRef termCount&) + Dim resPage As Visio.Page: Set resPage = ActivePage + + Dim basicWidth As Double: basicWidth = resPage.Document.Masters(MASTER_BASIC).Shapes(1).CellsU("Width") + Dim basicHeight As Double: basicHeight = resPage.Document.Masters(MASTER_BASIC).Shapes(1).CellsU("Height") + Dim derivedWidth As Double: derivedWidth = resPage.Document.Masters(MASTER_DERIVED).Shapes(1).Shapes(SHAPE_DERVIED).CellsU("Width") + Dim derivedHeight As Double: derivedHeight = resPage.Document.Masters(MASTER_DERIVED).Shapes(1).CellsU("Height") + + Dim basicX As Double: basicX = resPage.PageSheet.CellsU("XRulerOrigin") - BASE_START + Dim basicY As Double: basicY = resPage.PageSheet.CellsU("YRulerOrigin") - basicHeight / 2# + Dim derivedX As Double: derivedX = resPage.PageSheet.CellsU("XRulerOrigin") + Dim derivedY As Double: derivedY = resPage.PageSheet.CellsU("YRulerOrigin") + V_GAP + + Dim term As TermItem + Dim itemShape As Visio.Shape + Dim nItem&: nItem = 1: baseCount = 0: termCount = 0 + Do While nItem <= theData.Count + Set term = theData.Item(nItem) + Set itemShape = CreateItemShape(term, resPage) + If itemShape Is Nothing Then _ + GoTo NEXT_ITEM + + With itemShape + If term.Basic = True Then + itemShape.CellsU("PinX") = basicX - (BASIC_COLOMNS - 1 - baseCount Mod BASIC_COLOMNS) * (H_GAP + basicWidth) + itemShape.CellsU("Width") / 2# + itemShape.CellsU("PinY") = basicY - (baseCount \ BASIC_COLOMNS) * (V_GAP + basicHeight) + baseCount = baseCount + 1 + Else + itemShape.CellsU("PinX") = derivedX + (termCount \ DERIVED_ROWS) * (H_GAP + derivedWidth) + itemShape.CellsU("Width") / 2# + itemShape.CellsU("PinY") = derivedY + (1 + (termCount Mod DERIVED_ROWS)) * (V_GAP + derivedHeight) + termCount = termCount + 1 + End If + End With + +NEXT_ITEM: + nItem = nItem + 1 + Call CSE_ProgressBar.IncrementA + Loop +End Function + +Public Function ScanAllTerms(target As Visio.Page) As Scripting.Dictionary + Dim iData As New Scripting.Dictionary + + Dim theType As ShapeType + Dim aShape As Visio.Shape + For Each aShape In target.Shapes + theType = GetShapeType(aShape) + If theType = STYPE_GRID Or theType = STYPE_UNKNOWN Then _ + GoTo NEXT_SHAPE + If IsShapeDuplicate(aShape) Then _ + GoTo NEXT_SHAPE + + Dim sText$ + If theType = STYPE_DERIVED Then + sText = aShape.Shapes(S_D_TERM).Text + Else + sText = aShape.Text + End If + If sText <> "" Then _ + sText = VBA.LCase(VBA.Left(sText, 1)) & VBA.Right(sText, VBA.Len(sText) - 1) + + If Not iData.Exists(sText) Then _ + Set iData(sText) = aShape + +NEXT_SHAPE: + Next aShape + + Set ScanAllTerms = iData +End Function + +' ============== +Private Function CenterScreenOnShape(target As Visio.Shape) + Dim pinLeft As Double, pinTop As Double, pinWidth As Double, pinHeight As Double + Call Visio.Application.ActiveWindow.GetViewRect(pinLeft, pinTop, pinWidth, pinHeight) + Call Visio.Application.ActiveWindow.SetViewRect(target.CellsU("PinX") - pinWidth / 2#, _ + target.CellsU("PinY") + pinHeight / 2#, _ + pinWidth, pinHeight) +End Function + + +Private Function ScanExcel(dataSheet As Excel.Worksheet) As Collection +' Extracting data from Excel + Dim result As New Collection + + Dim lstrow&: lstrow = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Row + Dim nRow&: nRow = 2 + Dim newItem As TermItem + For nRow = 2 To lstrow + Set newItem = New TermItem + With newItem + .name_ = dataSheet.Cells(nRow, 1) + .definition_ = dataSheet.Cells(nRow, 2) + .source_ = dataSheet.Cells(nRow, 3) + End With + + Call result.Add(newItem) + Next nRow + + Set ScanExcel = result +End Function + +Private Function PrepareCompareOutput(target As Excel.Workbook) + Call target.Sheets.Add + Call target.Sheets.Add + With target.Sheets(1) + .Name = "Source1" + .Cells(1, XL_TS_ID) = "ShapeID" + .Cells(1, XL_TS_NAME) = "" + .Cells(1, XL_TS_DEFINITION) = "" + .Columns(XL_TS_NAME).ColumnWidth = 30 + .Columns(XL_TS_DEFINITION).ColumnWidth = 60 + .Rows(1).Font.Bold = True + End With + + With target.Sheets(2) + .Name = "Source2" + .Cells(1, XL_TS_ID) = "ShapeID" + .Cells(1, XL_TS_NAME) = "" + .Cells(1, XL_TS_DEFINITION) = "" + .Columns(XL_TS_NAME).ColumnWidth = 30 + .Columns(XL_TS_DEFINITION).ColumnWidth = 60 + .Rows(1).Font.Bold = True + End With + + With target.Sheets(3) + .Name = "Compare" + .Cells(1, XL_COMP_1ST) = " 1" + .Cells(1, XL_COMP_2ND) = " 2" + .Cells(1, XL_COMP_SHARED) = "" + .Columns(XL_COMP_1ST).ColumnWidth = 30 + .Columns(XL_COMP_2ND).ColumnWidth = 30 + .Columns(XL_COMP_SHARED).ColumnWidth = 30 + .Rows(1).Font.Bold = True + End With + + Dim ws As Excel.Worksheet + For Each ws In target.Worksheets + Call ws.Activate + With Excel.ActiveWindow + .SplitColumn = 0 + .SplitRow = 1 + .FreezePanes = True + End With + Next ws +End Function + +Private Function FinalizeCompare(target As Excel.Workbook) + Call target.Sheets(1).Range("A:C").Sort(key1:=target.Sheets(1).Range("B1"), order1:=xlAscending, Header:=xlYes) + Call target.Sheets(2).Range("A:C").Sort(key1:=target.Sheets(2).Range("B1"), order1:=xlAscending, Header:=xlYes) + Call target.Sheets(3).Range("A:A").Sort(key1:=target.Sheets(3).Range("A1"), order1:=xlAscending, Header:=xlYes) + Call target.Sheets(3).Range("B:B").Sort(key1:=target.Sheets(3).Range("B1"), order1:=xlAscending, Header:=xlYes) + Call target.Sheets(3).Range("C:C").Sort(key1:=target.Sheets(3).Range("C1"), order1:=xlAscending, Header:=xlYes) +End Function + +Private Function GetMostRightPos() As Double + GetMostRightPos = MOST_LEFT + + Dim aShape As Visio.Shape + Dim rightX As Double + For Each aShape In ActivePage.Shapes + If GetShapeType(aShape) = STYPE_GRID Then _ + GoTo NEXT_SHAPE + rightX = aShape.CellsU("PinX") + aShape.CellsU("Width") / 2# + H_GAP + GetMostRightPos = IIf(rightX <= GetMostRightPos, GetMostRightPos, rightX) + +NEXT_SHAPE: + Next aShape +End Function diff --git a/src/NewConcept.frm b/src/NewConcept.frm new file mode 100644 index 0000000..790c45b --- /dev/null +++ b/src/NewConcept.frm @@ -0,0 +1,41 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} NewConcept + ClientHeight = 3915 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 6225 + OleObjectBlob = "NewConcept.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "NewConcept" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public isCancelled_ As Boolean + +Private Sub UserForm_Initialize() + isCancelled_ = True +End Sub + +Private Sub OkBtn_Click() + isCancelled_ = False + Me.Hide +End Sub + +Private Sub CancelBtn_Click() + isCancelled_ = True + Me.Hide +End Sub + +Public Function GetTerm() As TermItem + Set GetTerm = New TermItem + With GetTerm + .name_ = Me.TermInput.Value + .definition_ = Me.NotionInput.Value + .source_ = Me.SourceInput.Value + End With +End Function + diff --git a/src/NewConcept.frx b/src/NewConcept.frx new file mode 100644 index 0000000..4da8196 Binary files /dev/null and b/src/NewConcept.frx differ diff --git a/src/RankGrid.cls b/src/RankGrid.cls new file mode 100644 index 0000000..efbfe5d --- /dev/null +++ b/src/RankGrid.cls @@ -0,0 +1,211 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "RankGrid" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Module for manipulating that grid ============ +Option Explicit + +Private lines_ As Collection +Private page_ As Visio.Page +Private rankHeight_ As Double + +Public Function Init(aPage As Visio.Page) + Set page_ = aPage + Call ScanShapes +End Function + +Public Property Get Size() As Integer + Size = lines_.Count +End Property + +Public Property Get Width() As Double + If lines_.Count = 0 Then _ + Exit Function + Width = Abs(lines_(1).CellsU("BeginX") - lines_(1).CellsU("EndX")) +End Property + +Public Function GetRankFor(target As Visio.Shape) As Integer + GetRankFor = RANK_UNREACHABLE + If lines_.Count = 0 Then _ + Exit Function + + Dim yPos As Double: yPos = target.CellsU("PinY") + If yPos < lines_.Item(lines_.Count).CellsU("PinY") Then _ + Exit Function + + Dim nGridShape%: nGridShape = 1 + Dim iShape As Visio.Shape + For Each iShape In lines_ + If yPos > iShape.CellsU("PinY") Then + GetRankFor = nGridShape - 1 + Exit Function + End If + nGridShape = nGridShape + 1 + Next iShape +End Function + +Public Function CreateGrid(nCount%, dHeight As Double, dWidth As Double, dTopMargin As Double, dLeftMargin As Double) + Call DeleteGrid + If nCount < 1 Then _ + Exit Function + + Dim dOriginX As Double: dOriginX = page_.PageSheet.CellsU("XGridOrigin") + dLeftMargin + Dim dEndX As Double: dEndX = dOriginX + dWidth + Dim dOriginY As Double: dOriginY = page_.PageSheet.CellsU("YGridOrigin") - dTopMargin + rankHeight_ = dHeight + + Dim nRank% + For nRank = 1 To nCount Step 1 + Dim iLine As Visio.Shape: Set iLine = page_.Drop(FindMaster(page_.Document, MASTER_LEVEL), dOriginX, dOriginY) + Call lines_.Add(iLine) + With iLine + .CellsU("BeginX") = dOriginX + .CellsU("EndX") = dEndX + .CellsU("BeginY") = dOriginY - (nRank - 1) * rankHeight_ + .CellsU("EndY") = .CellsU("BeginY") + .Name = PREFIX_GRID + CStr(nRank) + End With + Next nRank +End Function + +Public Function DeleteGrid() + Dim iShape As Visio.Shape + For Each iShape In lines_ + Call iShape.Delete + Next iShape + Set lines_ = New Collection +End Function + +Public Function MoveUp(target As Visio.Shape) As Boolean + MoveUp = False + + Dim nRank%: nRank = GetRankFor(target) + If nRank = RANK_UNREACHABLE Then _ + nRank = Size + + MoveUp = MoveToRank(target, nRank - 1) +End Function + +Public Function MoveDown(target As Visio.Shape) As Boolean + MoveDown = False + + Dim nRank%: nRank = GetRankFor(target) + If nRank = RANK_UNREACHABLE Then _ + Exit Function + + MoveDown = MoveToRank(target, nRank + 1) +End Function + +Public Function MoveToRank(target As Visio.Shape, nRank%) As Boolean + MoveToRank = False + If nRank > RANK_MAX Or nRank < 0 Then _ + Exit Function + If Size() = 0 Then _ + Exit Function + MoveToRank = True + + If nRank = 0 Then + target.CellsU("PinY") = lines_.Item(1).CellsU("PinY") + V_GAP + target.CellsU("Height") / 2# + Exit Function + End If + + Do While nRank + 1 > lines_.Count + Dim newShape As Visio.Shape: Set newShape = CreateShape(MASTER_LEVEL, page_) + Dim prevLine As Visio.Shape: Set prevLine = lines_.Item(lines_.Count) + Call lines_.Add(newShape) + With newShape + .CellsU("BeginX") = prevLine.CellsU("BeginX") + .CellsU("EndX") = prevLine.CellsU("EndX") + .CellsU("BeginY") = prevLine.CellsU("BeginY") - rankHeight_ + .CellsU("EndY") = prevLine.CellsU("EndY") - rankHeight_ + .Name = GetNextLineName + End With + Loop + + target.CellsU("PinY") = (lines_.Item(nRank + 1).CellsU("PinY") + lines_.Item(nRank).CellsU("PinY")) / 2# +End Function + +Public Function IncrementWidth(dIncrement As Double) As Boolean + IncrementWidth = False + + If lines_.Count = 0 Then _ + Exit Function + If dIncrement = 0 Then + IncrementWidth = True + Exit Function + End If + + Dim bFirst As Boolean: bFirst = True + Dim dBeginX As Double + Dim dWidth As Double + Dim iLine As Visio.Shape + For Each iLine In lines_ + If bFirst Then + bFirst = False + dWidth = Abs(iLine.CellsU("BeginX") - iLine.CellsU("EndX")) + dIncrement + If dWidth < 0 Then _ + Exit Function + dBeginX = iLine.CellsU("BeginX") + End If + + iLine.CellsU("BeginX") = dBeginX + iLine.CellsU("EndX") = dBeginX + dWidth + Next iLine + + IncrementWidth = True +End Function + +' ============= +Private Function ScanShapes() + Set lines_ = New Collection + Dim iLines As Collection: Set iLines = GetGridLines + If iLines.Count < 2 Then _ + Exit Function + + Dim iShape As Visio.Shape + Do While iLines.Count <> 0 + Dim curMax As Double: curMax = -999999 + Dim nMax&: nMax = -1 + Dim nItem&: nItem = 1 + For Each iShape In iLines + If curMax < iShape.CellsU("PinY") Then + nMax = nItem + curMax = iShape.CellsU("PinY") + End If + nItem = nItem + 1 + Next iShape + + Call lines_.Add(iLines.Item(nMax)) + Call iLines.Remove(nMax) + Loop + + rankHeight_ = Abs(lines_.Item(lines_.Count).CellsU("PinY") - lines_.Item(lines_.Count - 1).CellsU("PinY")) +End Function + +Private Function GetGridLines() As Collection + Dim iLines As New Collection + Dim iShape As Visio.Shape + For Each iShape In page_.Shapes + If iShape.Name Like MASK_LEVEL Then _ + Call iLines.Add(iShape) + Next iShape + Set GetGridLines = iLines +End Function + +Private Function GetNextLineName() As String + Dim nLine%: nLine = lines_.Count + Dim sName$ + Do While True + sName = PREFIX_GRID & nLine + If Not VsoShapeExists(sName, page_) Then + GetNextLineName = sName + Exit Function + End If + nLine = nLine + 1 + Loop +End Function diff --git a/src/TermItem.cls b/src/TermItem.cls new file mode 100644 index 0000000..29e9270 --- /dev/null +++ b/src/TermItem.cls @@ -0,0 +1,19 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "TermItem" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public name_ As String +Public definition_ As String +Public source_ As String + +Property Get Basic() As Boolean + Basic = definition_ = "" +End Property + diff --git a/src/ThisDocument.cls b/src/ThisDocument.cls new file mode 100644 index 0000000..f6ae9df --- /dev/null +++ b/src/ThisDocument.cls @@ -0,0 +1,21 @@ +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/s_RankGrid.cls b/src/s_RankGrid.cls new file mode 100644 index 0000000..183a0a9 --- /dev/null +++ b/src/s_RankGrid.cls @@ -0,0 +1,251 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_RankGrid" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private page_ As Visio.Page +Private grid_ As RankGrid + +Public Function Setup() + ' Mandatory setup function + Set page_ = ThisDocument.Pages.Add + Set grid_ = New RankGrid: Call grid_.Init(page_) +End Function + +Public Function Teardown() + ' Mandatory teardown function3 + Call page_.Delete(0) +End Function + +Public Function t_Access() + On Error GoTo PROPAGATE_ERROR + + Dim theGrid As New RankGrid + Dim iElement As Visio.Shape: Set iElement = page_.Drop(FindMaster(ThisDocument, MASTER_BASIC), 0, 0) + + Call Dev_NewCase("No grid") + Call theGrid.Init(page_) + Call Dev_ExpectEQ(0, theGrid.Size) + Call Dev_ExpectEQ(RANK_UNREACHABLE, theGrid.GetRankFor(iElement)) + + Call Dev_NewCase("Custom grid") + Dim iLine1 As Visio.Shape: Set iLine1 = page_.Drop(FindMaster(ThisDocument, MASTER_LEVEL), 0, 5) + iLine1.Name = PREFIX_GRID & "1" + Dim iLine2 As Visio.Shape: Set iLine2 = page_.Drop(FindMaster(ThisDocument, MASTER_LEVEL), 0, -5) + iLine2.Name = PREFIX_GRID & "2" + Call theGrid.Init(page_) + Call Dev_ExpectEQ(2, theGrid.Size) + + Call Dev_NewCase("Ranks") + Call Dev_ExpectEQ(1, theGrid.GetRankFor(iElement), "Mid") + iElement.CellsU("PinY") = 15 + Call Dev_ExpectEQ(0, theGrid.GetRankFor(iElement), "Top") + iElement.CellsU("PinY") = -15 + Call Dev_ExpectEQ(RANK_UNREACHABLE, theGrid.GetRankFor(iElement), "Bottom") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CreateGrid() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Invalid rank") + On Error Resume Next + Call grid_.CreateGrid(0, 10, 30, 1, 1) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + Call Dev_ExpectEQ(0, page_.Shapes.Count, "Do not create anything") + + Call Dev_NewCase("Valid grid") + Call grid_.CreateGrid(3, dHeight:=10, dWidth:=30, dTopMargin:=1, dLeftMargin:=2) + Call Dev_ExpectEQ(3, page_.Shapes.Count, "Shapes count") + Call Dev_ExpectAEQ(10, page_.Shapes("SLevel1").CellsU("PinY") - page_.Shapes.Item("SLevel2").CellsU("PinY"), 2, "Height") + Call Dev_ExpectAEQ(30, page_.Shapes("SLevel1").CellsU("Width"), 2, "Width") + Call Dev_ExpectAEQ(grid_.Width, page_.Shapes("SLevel1").CellsU("Width"), 2, "Width") + Call Dev_ExpectAEQ(-1, page_.Shapes("SLevel1").CellsU("PinY") - page_.PageSheet.CellsU("YGridOrigin"), 2, "Top Margin") + Call Dev_ExpectAEQ(2, page_.Shapes("SLevel1").CellsU("BeginX") - page_.PageSheet.CellsU("XGridOrigin"), 2, "Left Margin") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DeleteGrid() + On Error GoTo PROPAGATE_ERROR + + Dim iElement As Visio.Shape: Set iElement = page_.Drop(FindMaster(ThisDocument, MASTER_BASIC), 0, 0) + Dim nID&: nID = iElement.ID + + Call Dev_NewCase("No grid") + On Error Resume Next + Call grid_.DeleteGrid + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + Call Dev_ExpectEQ(1, page_.Shapes.Count, "Do not remove existing shapes") + + Call Dev_NewCase("Valid grid") + Call grid_.CreateGrid(3, dHeight:=10, dWidth:=30, dTopMargin:=1, dLeftMargin:=2) + Call grid_.DeleteGrid + Call Dev_ExpectEQ(1, page_.Shapes.Count, "Shapes count") + Call Dev_ExpectEQ(nID, page_.Shapes(1).ID) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_MoveShape() + On Error GoTo PROPAGATE_ERROR + + Dim iElement As Visio.Shape: Set iElement = page_.Drop(FindMaster(ThisDocument, MASTER_BASIC), 0, 0) + + Call Dev_NewCase("No grid") + On Error Resume Next + Call Dev_ExpectFalse(grid_.MoveToRank(iElement, 0)) + Call Dev_ExpectNoError + Call Dev_ExpectFalse(grid_.MoveUp(iElement)) + Call Dev_ExpectNoError + Call Dev_ExpectFalse(grid_.MoveDown(iElement)) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call grid_.CreateGrid(3, dHeight:=10, dWidth:=30, dTopMargin:=1, dLeftMargin:=2) + Dim iLevel1 As Visio.Shape: Set iLevel1 = page_.Shapes("SLevel1") + Dim iLevel2 As Visio.Shape: Set iLevel2 = page_.Shapes("SLevel2") + Dim iLevel3 As Visio.Shape: Set iLevel3 = page_.Shapes("SLevel3") + + Call Dev_NewCase("Move valid") + Call Dev_ExpectTrue(grid_.MoveToRank(iElement, 0)) + Call Dev_ExpectEQ(0, grid_.GetRankFor(iElement)) + Call Dev_ExpectGR(iElement.CellsU("PinY"), iLevel1.CellsU("PinY")) + + Call Dev_ExpectTrue(grid_.MoveToRank(iElement, 1)) + Call Dev_ExpectEQ(1, grid_.GetRankFor(iElement)) + Call Dev_ExpectLS(iElement.CellsU("PinY"), iLevel1.CellsU("PinY")) + Call Dev_ExpectGR(iElement.CellsU("PinY"), iLevel2.CellsU("PinY")) + + Call Dev_ExpectTrue(grid_.MoveUp(iElement)) + Call Dev_ExpectEQ(0, grid_.GetRankFor(iElement)) + Call Dev_ExpectFalse(grid_.MoveUp(iElement)) + Call Dev_ExpectTrue(grid_.MoveDown(iElement)) + Call Dev_ExpectEQ(1, grid_.GetRankFor(iElement)) + + + Call Dev_NewCase("Move from top") + iElement.Cells("PinY") = 100 + Call Dev_ExpectEQ(0, grid_.GetRankFor(iElement)) + Call Dev_ExpectTrue(grid_.MoveToRank(iElement, 2), "MoveTo") + Call Dev_ExpectEQ(2, grid_.GetRankFor(iElement), "MoveTo") + + iElement.Cells("PinY") = 100 + Call Dev_ExpectFalse(grid_.MoveUp(iElement), "Move up") + Call Dev_ExpectEQ(0, grid_.GetRankFor(iElement), "Move up") + + iElement.Cells("PinY") = 100 + Call Dev_ExpectTrue(grid_.MoveDown(iElement), "Move down") + Call Dev_ExpectEQ(1, grid_.GetRankFor(iElement), "Move down") + + Call Dev_NewCase("Move from bottom") + iElement.Cells("PinY") = -100 + Call Dev_ExpectEQ(RANK_UNREACHABLE, grid_.GetRankFor(iElement)) + Call Dev_ExpectTrue(grid_.MoveToRank(iElement, 2), "MoveTo") + Call Dev_ExpectEQ(2, grid_.GetRankFor(iElement), "MoveTo") + + iElement.Cells("PinY") = -100 + Call Dev_ExpectTrue(grid_.MoveUp(iElement), "Move up") + Call Dev_ExpectEQ(2, grid_.GetRankFor(iElement), "Move up") + + iElement.Cells("PinY") = -100 + Call Dev_ExpectFalse(grid_.MoveDown(iElement), "Move down") + Call Dev_ExpectEQ(RANK_UNREACHABLE, grid_.GetRankFor(iElement), "Move down") + + Call Dev_NewCase("Create additional levels") + Call Dev_ExpectTrue(grid_.MoveToRank(iElement, 2)) + Call Dev_ExpectTrue(grid_.MoveDown(iElement), "Move down") + Call Dev_ExpectEQ(3, grid_.GetRankFor(iElement), "Move down") + Call Dev_ExpectEQ(4, grid_.Size, "Move down") + + Call Dev_ExpectTrue(grid_.MoveToRank(iElement, 6), "Move to") + Call Dev_ExpectEQ(6, grid_.GetRankFor(iElement), "Move to") + Call Dev_ExpectEQ(7, grid_.Size, "Move to") + Call Dev_ExpectTrue(grid_.MoveToRank(iElement, RANK_MAX), "Max rank") + Call Dev_ExpectFalse(grid_.MoveDown(iElement), "Max rank") + Call Dev_ExpectFalse(grid_.MoveToRank(iElement, RANK_MAX + 1), "Max rank") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CustomGrid() + On Error GoTo PROPAGATE_ERROR + + Dim iElement As Visio.Shape: Set iElement = page_.Drop(FindMaster(ThisDocument, MASTER_BASIC), 0, 0) + Call grid_.CreateGrid(3, dHeight:=10, dWidth:=30, dTopMargin:=1, dLeftMargin:=2) + Dim iLevel1 As Visio.Shape: Set iLevel1 = page_.Shapes("SLevel1") + Dim iLevel2 As Visio.Shape: Set iLevel2 = page_.Shapes("SLevel2") + Dim iLevel3 As Visio.Shape: Set iLevel3 = page_.Shapes("SLevel3") + + iLevel1.CellsU("BeginY") = -10 + iLevel1.CellsU("EndY") = -10 + iLevel3.CellsU("BeginY") = 10 + iLevel3.CellsU("EndY") = 10 + Call iLevel2.Delete + + Call grid_.Init(page_) + + Call Dev_ExpectEQ(2, grid_.Size, "Grid size") + Call Dev_ExpectTrue(grid_.MoveToRank(iElement, 1), "Valid move") + Call Dev_ExpectEQ(1, grid_.GetRankFor(iElement), "Valid move") + Call Dev_ExpectLS(iElement.CellsU("PinY"), iLevel3.CellsU("PinY"), "Level ordering") + Call Dev_ExpectGR(iElement.CellsU("PinY"), iLevel1.CellsU("PinY"), "Level ordering") + + Call Dev_NewCase("Add level") + Call Dev_ExpectTrue(grid_.MoveDown(iElement), "Move down") + Call Dev_ExpectEQ(2, grid_.GetRankFor(iElement), "Move down") + Call Dev_ExpectEQ(3, grid_.Size, "Move down") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ChangeWidth() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("No grid") + On Error Resume Next + Call Dev_ExpectFalse(grid_.IncrementWidth(10)) + Call Dev_ExpectNoError + Call Dev_ExpectFalse(grid_.IncrementWidth(-10)) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call grid_.CreateGrid(3, dHeight:=10, dWidth:=30, dTopMargin:=1, dLeftMargin:=2) + Dim iLevel1 As Visio.Shape: Set iLevel1 = page_.Shapes("SLevel1") + Dim iLevel2 As Visio.Shape: Set iLevel2 = page_.Shapes("SLevel2") + Dim iLevel3 As Visio.Shape: Set iLevel3 = page_.Shapes("SLevel3") + iLevel2.CellsU("BeginX") = 10 + + Call Dev_NewCase("Valid grid") + Call Dev_ExpectTrue(grid_.IncrementWidth(10)) + Call Dev_ExpectAEQ(iLevel1.CellsU("BeginX"), iLevel2.CellsU("BeginX"), 2, "Alignment") + Call Dev_ExpectAEQ(40, grid_.Width, 2, "Expand Width") + Call Dev_ExpectTrue(grid_.IncrementWidth(-10)) + Call Dev_ExpectAEQ(30, grid_.Width, 2, "Shrink Width") + + Call Dev_NewCase("Invalid increment") + Call Dev_ExpectFalse(grid_.IncrementWidth(-1000)) + + 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..c10f347 --- /dev/null +++ b/src/z_UIMessages.bas @@ -0,0 +1,71 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + EM_INVALID_LEVEL + EM_EMPTY_SELECTION + EM_INVALID_FILE_FORMAT + EM_TEMPLATE_MISSING + EM_INVALID_WIDTH + EM_PYTHON_ERROR + + IM_GENEARION_COMPLETE + IM_EXPORT_DIFF_COMPLETE + IM_EXPORT_XL_COMPLETE + + 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_INVALID_LEVEL: Call MsgBox(" ", vbExclamation) + Case EM_EMPTY_SELECTION: Call MsgBox(" -!", vbExclamation) + Case EM_INVALID_FILE_FORMAT: Call MsgBox("Invalid file format", vbExclamation) + Case EM_TEMPLATE_MISSING: Call MsgBox(" . ", vbExclamation) + Case EM_INVALID_WIDTH: Call MsgBox(" ", vbExclamation) + Case EM_PYTHON_ERROR: Call MsgBox(Fmt("Python error: {1}", unwrapped), vbInformation) + + Case IM_GENEARION_COMPLETE: Call MsgBox(Fmt(" !" & vbNewLine & _ + " : {1}" & vbNewLine & _ + " : {2}", unwrapped), vbInformation) + Case IM_EXPORT_DIFF_COMPLETE: Call MsgBox(" ", vbInformation) + Case IM_EXPORT_XL_COMPLETE: 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..07ecfeb --- /dev/null +++ b/src/z_UIRibbon.bas @@ -0,0 +1,33 @@ +Attribute VB_Name = "z_UIRibbon" +Option Explicit + +Sub OnAction(control As IRibbonControl) + Select Case control.ID + Case "ImportExcel": Call RunImportExcel + Case "AddNotion": Call RunAddNotion + + Case "AddGrid": Call RunAddGrid + Case "DeleteGrid": Call RunDeleteGrid + + Case "Plus10": Call RunGridPlus10 + Case "Minus10": Call RunGridMinus10 + Case "DeltaX": Call RunGridChange + + Case "TopAlignment": Call CC_TopAlignment + Case "LeftAlignment": Call CC_LeftAlignment + + Case "MoveUp": Call RunMoveUp + Case "MoveDown": Call RunMoveDown + Case "MoveX": Call RunMoveToX + + Case "ExpandStraight": Call CC_ExpandStraight + Case "ExpandReverse": Call CC_ExpandReverse + Case "GotoLinkBegin": Call CC_GotoLinkBegin + Case "GotoLinkEnd": Call CC_GotoLinkEnd + + Case "ExportExcel": Call RunExportExcel + Case "CompareTo": Call RunCompare + Case "CleanUp": Call RunCleanUp + Case "Help": Call RunHelp + End Select +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..aeb2dcc --- /dev/null +++ b/ui/customUI1.xml @@ -0,0 +1,128 @@ + + + + + + +