commit bb026464a0145c1df613bc89379c5e4bc16e8a3a Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:13:55 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..68e631a --- /dev/null +++ b/VBAMake.txt @@ -0,0 +1,37 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home + +id = Concept-Subjects +name = Концепт-Субъекты +description = Технология визуализации позиций субъектов +artifact_home = Концепт-Субъекты +source_home = Concept-Subjects +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\!Реестр противоречий.xlsm +copy distr\Пример входных данных.xlsx +copy distr\Версии + +%% +# === Install section == +# Available commands: +# install LOCAL_ARTIFACT -> [INSTALL_PATH] +# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE] +# run LOCAL_ARTIFACT.bat <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + +install Версии +install !Карта субъектов.vsdm +install !Реестр противоречий.xlsm +install Пример входных данных.xlsx \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..3eefcb9 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +1.0.0 diff --git a/distr/!Реестр противоречий.xlsm b/distr/!Реестр противоречий.xlsm new file mode 100644 index 0000000..c8c37e9 Binary files /dev/null and b/distr/!Реестр противоречий.xlsm differ diff --git a/distr/Версии/Без фронтов/!Карта субъектов.vsdm b/distr/Версии/Без фронтов/!Карта субъектов.vsdm new file mode 100644 index 0000000..18d100d Binary files /dev/null and b/distr/Версии/Без фронтов/!Карта субъектов.vsdm differ diff --git a/distr/Версии/Без фронтов/Пример входных данных.xlsx b/distr/Версии/Без фронтов/Пример входных данных.xlsx new file mode 100644 index 0000000..7b235c2 Binary files /dev/null and b/distr/Версии/Без фронтов/Пример входных данных.xlsx differ diff --git a/distr/Пример входных данных.xlsx b/distr/Пример входных данных.xlsx new file mode 100644 index 0000000..c98b858 Binary files /dev/null and b/distr/Пример входных данных.xlsx differ diff --git a/script/manifest.txt b/script/manifest.txt new file mode 100644 index 0000000..228c7c5 --- /dev/null +++ b/script/manifest.txt @@ -0,0 +1,80 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = !Карта субъектов.vsdm +artifact = !Карта субъектов.vsdm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +dev + DevTester.bas + +api + ex_WinAPI.bas + API_VsoWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +utility + ex_VBA.bas + ex_Collection.bas + + CDS_NodeSH.cls + CDS_StaticHierarchy.cls + +visio + z_VsoUtilities.bas + API_ShapeStorage.cls + API_UndoWrapper.cls + +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 + ImportDialog.frm + + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + z_UIMessages.bas + z_UIRibbon.bas + + ShapeCreator.cls + VisioNode.cls + LayoutManager.cls + ContainerLayout.cls + PageLayout.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 : Shell32 +global : Scripting +global : Excel +global : MSForms \ No newline at end of file diff --git a/skeleton/!Карта субъектов.vsdm b/skeleton/!Карта субъектов.vsdm new file mode 100644 index 0000000..892d855 Binary files /dev/null and b/skeleton/!Карта субъектов.vsdm differ diff --git a/skeleton/Карта субъектов.vsdx b/skeleton/Карта субъектов.vsdx new file mode 100644 index 0000000..3503032 Binary files /dev/null and b/skeleton/Карта субъектов.vsdx differ diff --git a/src/ContainerLayout.cls b/src/ContainerLayout.cls new file mode 100644 index 0000000..914b7c4 --- /dev/null +++ b/src/ContainerLayout.cls @@ -0,0 +1,132 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ContainerLayout" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Reusable columns layout ========= +Option Explicit + +Private container_ As Visio.Shape + +Private margins_ As Double +Private headerSize_ As Double +Private maxHeight_ As Double + +Private columnWidth_ As Double +Private lastColumn_ As Collection +Private originX_ As Double +Private originY_ As Double +Private currentY_ As Double +Private currentX_ As Double + +Public Function Init(target As Visio.Shape, maxHeight As Double) + Set container_ = target + maxHeight_ = maxHeight + + margins_ = container_.CellsU(CELLSU_CONTAINER_MARGINS) + LM_MARGINS_EPSILON + headerSize_ = container_.Shapes(2).CellsU("Height") + + Call container_.Resize(visResizeDirS, container_.Shapes(2).CellsU("Height") + 2 * margins_ - container_.CellsU("Height"), visInches) + originY_ = container_.CellsU("PinY") + container_.CellsU("Height") / 2# + currentY_ = originY_ - container_.Shapes(2).CellsU("Height") - margins_ + + originX_ = container_.CellsU("PinX") - container_.CellsU("Width") / 2# + currentX_ = originX_ + margins_ + + columnWidth_ = 0 + Set lastColumn_ = New Collection +End Function + +Public Property Get AreaHeight() As Double + AreaHeight = container_.CellsU("Height") - 2 * margins_ - headerSize_ +End Property + +Public Property Get AreaWidth() As Double + AreaWidth = container_.CellsU("Width") - 2 * margins_ +End Property + +Public Function AddItem(target As Visio.Shape) + If Not CanAdd(target) Then _ + Call FinalizeColumn + Call AddShapeInternal(target) +End Function + +Public Function AddItemToNewColumn(target As Visio.Shape) + Call FinalizeColumn + Call AddShapeInternal(target) +End Function + +Public Function Finalize() + Call FinalizeColumn +End Function + +' ================ +Private Function CanAdd(target As Visio.Shape) As Boolean + If lastColumn_.Count = 0 Then + CanAdd = False + Exit Function + End If + + Dim newHeight As Double: newHeight = Abs(originY_ - currentY_) + target.CellsU("Height") + LM_VERTICAL_GAP + If Round(newHeight + margins_, DEPSILON) < Round(container_.CellsU("Height"), DEPSILON) Then + CanAdd = True + Exit Function + End If + + CanAdd = Round(newHeight + margins_, DEPSILON) < Round(maxHeight_, DEPSILON) +End Function + +Private Function AddShapeInternal(target As Visio.Shape) + Dim newHeight As Double: newHeight = Abs(originY_ - currentY_) + target.CellsU("Height") + Call EnsureHeight(newHeight + margins_) + + Dim newWidth As Double: newWidth = Abs(originX_ - currentX_) + target.CellsU("Width") + Call EnsureWidth(newWidth + margins_) + + Call target.SetCenter(originX_ + newWidth - target.CellsU("Width") / 2#, _ + originY_ - newHeight + target.CellsU("Height") / 2#) + currentY_ = originY_ - newHeight - LM_VERTICAL_GAP + If Round(target.CellsU("Width"), DEPSILON) > Round(columnWidth_, DEPSILON) Then _ + columnWidth_ = target.CellsU("Width") + + Call lastColumn_.Add(target) +End Function + +Private Function EnsureHeight(newHeight As Double) + If Round(newHeight, DEPSILON) < Round(container_.CellsU("Height"), DEPSILON) Then _ + Exit Function + Call container_.Resize(visResizeDirS, newHeight - container_.CellsU("Height"), visInches) +End Function + +Private Function EnsureWidth(newWidth As Double) + If Round(newWidth, DEPSILON) < Round(container_.CellsU("Width"), DEPSILON) Then _ + Exit Function + Call container_.Resize(visResizeDirE, newWidth - container_.CellsU("Width"), visInches) +End Function + +Private Function FinalizeColumn() + If lastColumn_.Count = 0 Then _ + Exit Function + + Call EqualizeWidth + + currentX_ = currentX_ + columnWidth_ + LM_HORIZONTAL_GAP + currentY_ = originY_ - container_.Shapes(2).CellsU("Height") - margins_ + columnWidth_ = 0 + Set lastColumn_ = New Collection +End Function + +Private Function EqualizeWidth() + Dim nItem& + Dim aShape As Visio.Shape + For nItem = 1 To lastColumn_.Count Step 1 + Set aShape = lastColumn_.Item(nItem) + If Round(columnWidth_, DEPSILON) > Round(aShape.CellsU("Width"), DEPSILON) Then + Call aShape.Resize(visResizeDirE, columnWidth_ - aShape.CellsU("Width"), visInches) + End If + Next nItem +End Function diff --git a/src/DataAcces.bas b/src/DataAcces.bas new file mode 100644 index 0000000..6178850 --- /dev/null +++ b/src/DataAcces.bas @@ -0,0 +1,52 @@ +Attribute VB_Name = "DataAcces" +Option Explicit + +Private Enum DataSourceStructure + DSS_ID = 1 + DSS_LEVEL = 2 + DSS_TYPE = 3 + DSS_TEXT_THEME = 4 + DSS_TEXT_SUBJECT = 5 +End Enum + +Public Function ScanExcel(target As Excel.Worksheet) As Hierarchy + Set ScanExcel = New Hierarchy + + Call CSE_ProgressBar.Init(" ", maxVal:=target.UsedRange.Rows.Count, curVal:=2) + Call CSE_ProgressBar.ShowModeless + + Dim theType As ItemType + Dim theText$ + Dim nRow&: nRow = 2 + Do While target.Cells(nRow, DSS_LEVEL) <> "" + theType = TextToType(target.Cells(nRow, DSS_TYPE)) + If theType = IT_ORGAN Or theType = IT_PERSON Or theType = IT_GROUP Then + theText = target.Cells(nRow, DSS_TEXT_SUBJECT) + Else + theText = target.Cells(nRow, DSS_TEXT_THEME) + End If + + If ScanExcel.AddItem(theType, target.Cells(nRow, DSS_LEVEL), theText) Is Nothing Then + Set ScanExcel = Nothing + Unload CSE_ProgressBar + Exit Function + End If + + Call CSE_ProgressBar.IncrementA + nRow = nRow + 1 + Loop + + Unload CSE_ProgressBar +End Function + +' =========== +Private Function TextToType(target$) As ItemType + Select Case target + Case SHP_TYPE_PROBLEM: TextToType = IT_PROBLEM + Case SHP_TYPE_POSITION: TextToType = IT_POSITION + Case SHP_TYPE_GROUP: TextToType = IT_GROUP + Case SHP_TYPE_ORGAN: TextToType = IT_ORGAN + Case SHP_TYPE_PERSON: TextToType = IT_PERSON + End Select +End Function + diff --git a/src/Declarations.bas b/src/Declarations.bas new file mode 100644 index 0000000..5847318 --- /dev/null +++ b/src/Declarations.bas @@ -0,0 +1,116 @@ +Attribute VB_Name = "Declarations" +Option Explicit + +Public Enum TItem + T_ITEM_UNKNOWN = 0 + [_First] = 1 + + T_ITEM_FRONT = 1 + T_ITEM_PROBLEM = 2 + T_ITEM_SUBJECT_TYPE = 3 + T_ITEM_GROUP = 4 + T_ITEM_ORGAN = 5 + T_ITEM_PERSON = 6 + + [_Last] = 6 +End Enum + +Public Enum TSubjectType + T_SUBJECT_UNKNOWN = 0 + [_First] = 1 + + T_SUBJECT_SOLVER = 1 + T_SUBJECT_INVOLVED = 2 + T_SUBJECT_POTENTIAL = 3 + + [_Last] = 3 +End Enum + +Public Const SHAPE_FRONT = "" +Public Const SHAPE_PROBLEM = "" +Public Const SHAPE_SUBJECT_TYPE = " " +Public Const SHAPE_ORGAN = "" +Public Const SHAPE_PERSON = "" +Public Const SHAPE_GROUP = "" + +Public Const XL_TYPE_FRONT = "" +Public Const XL_TYPE_PROBLEM = "" +Public Const XL_TYPE_SUBJECT_TYPE = " " +Public Const XL_TYPE_ORGAN = "" +Public Const XL_TYPE_PERSON = "" +Public Const XL_TYPE_GROUP = "" + +Public Const SHP_TITLE = "" + +Public Const MAX_STRUCTURE_DEPTH = 20 + +Public Const CELLSU_POSTYPE = "User.ThesisVariant" +Public Const CELLSU_CONTAINER_MARGINS = "User.msvSDContainerMargin" + +Public Const PROBLEM_PREFIX = "" +Public Const FRONT_PREFIX = " " + +Public Const DEPSILON = 3 + +' Layout manager options +Public Const LM_MARGINS_EPSILON = 0.5 / 25.4 ' Increase margins to ammount for line width etc. + +Public Const LM_VERTICAL_GAP = 2 / 25.4 +Public Const LM_HORIZONTAL_GAP = 2 / 25.4 + +Public Const PAGE_VERTICAL_GAP = 4 / 25.4 +Public Const PAGE_HORIZONTAL_GAP = 4 / 25.4 + +Public Const PAGE_TITLE_GAP = 25 / 25.4 ' Blank space in left corner for schema title + +Public Const HEIGHT_DOUBLE_THRESHOLD = 130 +Public Const HEIGHT_TRIPLE_THRESHOLD = 250 + +Public Type PageProps + width_ As Double + height_ As Double + frontHeight_ As Double + problemHeight_ As Double + leftGap_ As Double + columnGap_ As Double + addHeader_ As Boolean + multipage_ As Boolean +End Type + +' Custom errors +Public Enum CustomErrors + ERR_XL_INVALID_TYPE = vbObjectError + 1000 + ' ERR_SYNC_DOC +End Enum + +' ===== Excel input ========== +Public Const EXCEL_FIRST_ROW = 2 + +Public Enum DataSourceStructure + S_ITEM_ID = 1 + S_ITEM_LEVEL = 2 + S_ITEM_TYPE = 3 + S_ITEM_TEXT_THEME = 4 + S_ITEM_TEXT_SUBJECT = 5 +End Enum + +Public Function TextToItemType(sText$) As TItem + Select Case sText + Case XL_TYPE_FRONT: TextToItemType = T_ITEM_FRONT + Case XL_TYPE_PROBLEM: TextToItemType = T_ITEM_PROBLEM + Case XL_TYPE_SUBJECT_TYPE: TextToItemType = T_ITEM_SUBJECT_TYPE + Case XL_TYPE_GROUP: TextToItemType = T_ITEM_GROUP + Case XL_TYPE_ORGAN: TextToItemType = T_ITEM_ORGAN + Case XL_TYPE_PERSON: TextToItemType = T_ITEM_PERSON + Case Else: TextToItemType = T_ITEM_UNKNOWN + End Select +End Function + +Public Function TextToSubjectType(sText$) As TSubjectType + Select Case sText + Case " ": TextToSubjectType = T_SUBJECT_SOLVER + Case " ": TextToSubjectType = T_SUBJECT_INVOLVED + Case " ": TextToSubjectType = T_SUBJECT_POTENTIAL + Case Else: TextToSubjectType = T_SUBJECT_POTENTIAL + End Select +End Function diff --git a/src/DevHelper.bas b/src/DevHelper.bas new file mode 100644 index 0000000..a3de084 --- /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 ClearMain +End Function + +Public Function Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_UndoWrapper" + Dim sTest$: sTest = "t_BasicUndo" + Dim sMsg$: sMsg = Dev_RunTest(sSuite, sTest) + Debug.Print sMsg + Call MsgBox(sMsg) +End Function + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + ' Case "s_UndoWrapper": Set Dev_GetTestSuite = New s_UndoWrapper + End Select +End Function diff --git a/src/ImportDialog.frm b/src/ImportDialog.frm new file mode 100644 index 0000000..e1cda30 --- /dev/null +++ b/src/ImportDialog.frm @@ -0,0 +1,75 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ImportDialog + Caption = " " + ClientHeight = 5115 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 3525 + OleObjectBlob = "ImportDialog.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "ImportDialog" +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 UserForm_Terminate() + isCancelled_ = True + Call Me.Hide +End Sub + +Public Function Init(pHeightInMM As Double) + isCancelled_ = True + TBPrintHeight.Value = CLng(pHeightInMM) +End Function + +Public Property Get FileName() As String + FileName = TBDocument.Text +End Property + +Public Function GetProps() As PageProps + With GetProps + .addHeader_ = CBTitle.Value + .multipage_ = CBMultipage.Value + .height_ = Visio.Application.ConvertResult(TBPrintHeight.Value, visMillimeters, visInches) + .width_ = Visio.Application.ConvertResult(TBPrintWidth.Value, visMillimeters, visInches) + .problemHeight_ = Visio.Application.ConvertResult(TBIemHeight.Value, visMillimeters, visInches) + .frontHeight_ = Visio.Application.ConvertResult(TBFrontHeight.Value, visMillimeters, visInches) + .leftGap_ = Visio.Application.ConvertResult(TBHorizontalGap.Value, visMillimeters, visInches) + .columnGap_ = Visio.Application.ConvertResult(TBColumnGap.Value, visMillimeters, visInches) + End With +End Function + +' ========== +Private Sub DocumentBtn_Click() + Dim sFile$: sFile = UserInteraction.PromptFileFilter( _ + sInitialPath:=ThisDocument.Path, _ + bNewApplication:=True, _ + sDescription:=" Excel", _ + sFilter:="*.xlsx;*.xls;*.xlsm") + If sFile <> vbNullString Then _ + TBDocument.Text = sFile +End Sub + +Private Sub CancelBtn_Click() + isCancelled_ = True + Call Me.Hide +End Sub + +Private Sub OkBtn_Click() + If FileName = vbNullString Then + Call UserInteraction.ShowMessage(EM_VALIDATION_FAIL) + Exit Sub + End If + + isCancelled_ = False + Call Me.Hide +End Sub diff --git a/src/ImportDialog.frx b/src/ImportDialog.frx new file mode 100644 index 0000000..2616d02 Binary files /dev/null and b/src/ImportDialog.frx differ diff --git a/src/LayoutManager.cls b/src/LayoutManager.cls new file mode 100644 index 0000000..738b587 --- /dev/null +++ b/src/LayoutManager.cls @@ -0,0 +1,200 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "LayoutManager" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== Shape layout and combination logic ======== +Option Explicit + +Private data_ As CDS_StaticHierarchy +Private storage_ As API_ShapeStorage + +Private parentPage_ As Visio.Page + +Private pageProps_ As PageProps +Private originX_ As Double +Private originY_ As Double + +Public Function Init(ByRef theData As CDS_StaticHierarchy, ByRef iStorage As API_ShapeStorage, originX As Double, originY As Double) + Set data_ = theData + Set storage_ = iStorage + Set parentPage_ = iStorage.TargetPage + originX_ = originX + originY_ = originY +End Function + +Public Function CombineContainers(props As PageProps) + pageProps_ = props + Dim iNode As CDS_NodeSH + For Each iNode In data_.nodes_ + If iNode.rank_ = 1 Then _ + Call PrepareItem(iNode, props.frontHeight_) + Call CSE_ProgressBar.IncrementA + Next iNode + Call ActiveWindow.Selection.DeselectAll +End Function + +Public Function Build(props As PageProps) + Dim iPage As New PageLayout: Call iPage.Init(parentPage_, props) + Dim itemShape As Visio.Shape + Dim iNode As CDS_NodeSH + For Each iNode In data_.nodes_ + If iNode.rank_ = 1 Then + Set itemShape = iNode.data_.shape_ + Call storage_.GiveBack(itemShape) + Call iPage.AddItem(itemShape) + Call CSE_ProgressBar.IncrementA + End If + Next iNode + Call iPage.FinalizePage +End Function + +' ======= +Private Function PrepareItem(target As CDS_NodeSH, dMaxHeight As Double) ' recursive + If target.children_.Count = 0 Then _ + Exit Function + Select Case target.data_.type_ + Case T_ITEM_FRONT: Call PrepareFront(target) + Case T_ITEM_PROBLEM: Call PrepareProblem(target, pageProps_.problemHeight_) + Case T_ITEM_SUBJECT_TYPE, T_ITEM_GROUP: Call PrepareContainer(target, dMaxHeight) + Case T_ITEM_ORGAN: Call PrepareOrgan(target) + Case Else: Call Err.Raise(1000, Description:="Structural error in " & target.data_.text_) ' TODO: specify err number + End Select +End Function + +Private Function PrepareChildren(target As CDS_NodeSH, dMaxHeight As Double) + Dim iChildNode As CDS_NodeSH + For Each iChildNode In target.children_ + Call PrepareItem(iChildNode, dMaxHeight) + Next iChildNode +End Function + +Private Function PrepareFront(target As CDS_NodeSH) + Dim dHeight As Double: dHeight = pageProps_.frontHeight_ + If target.descendantsCount_ > HEIGHT_TRIPLE_THRESHOLD Then + dHeight = dHeight * 3 + ElseIf target.descendantsCount_ > HEIGHT_DOUBLE_THRESHOLD Then + dHeight = dHeight * 2 + End If + Dim iLayout As ContainerLayout + Set iLayout = CreateLayout(target, dHeight) + Call storage_.GiveBack(target.data_.shape_) + Call IncludeFrontChildren(target, iLayout) + Call iLayout.Finalize + Call storage_.Store(target.data_.shape_) +End Function + +Private Function PrepareProblem(target As CDS_NodeSH, dMaxHeight As Double) + Dim iLayout As ContainerLayout + Set iLayout = CreateLayout(target, dMaxHeight) + Call storage_.GiveBack(target.data_.shape_) + Call IncludeProblemChildren(target, iLayout) + Call iLayout.Finalize + Call storage_.Store(target.data_.shape_) +End Function + +Private Function PrepareContainer(target As CDS_NodeSH, dMaxHeight As Double) + Dim iLayout As ContainerLayout + Set iLayout = CreateLayout(target, dMaxHeight) + Call storage_.GiveBack(target.data_.shape_) + Call IncludeContainerChildren(target, iLayout) + Call iLayout.Finalize + Call storage_.Store(target.data_.shape_) +End Function + +Private Function PrepareOrgan(target As CDS_NodeSH) + Call storage_.GiveBack(target.data_.shape_) + Set target.data_.shape_ = GroupWithChildren(target) + Call storage_.Store(target.data_.shape_) +End Function + +Private Function CreateLayout(target As CDS_NodeSH, dMaxHeight As Double) As ContainerLayout + Dim iParent As Visio.Shape: Set iParent = target.data_.shape_ + Dim newMaxHeight As Double: newMaxHeight = dMaxHeight - HeightBoilerplate(iParent) + Call PrepareChildren(target, newMaxHeight) + + Call iParent.SetCenter(originX_ + iParent.CellsU("Width") / 2#, originY_ - iParent.CellsU("Height") / 2#) + Dim aLayout As New ContainerLayout: Call aLayout.Init(iParent, dMaxHeight) + Set CreateLayout = aLayout +End Function + +Private Function IncludeFrontChildren(target As CDS_NodeSH, iLayout As ContainerLayout) + Dim iChildNode As CDS_NodeSH + For Each iChildNode In target.children_ + Dim iChild As Visio.Shape: Set iChild = iChildNode.data_.shape_ + Call storage_.GiveBack(iChild) + Call iLayout.AddItem(iChild) + Next iChildNode +End Function + +Private Function IncludeProblemChildren(target As CDS_NodeSH, iLayout As ContainerLayout) + Dim iChildNode As CDS_NodeSH + For Each iChildNode In target.children_ + Dim iChild As Visio.Shape: Set iChild = iChildNode.data_.shape_ + Call storage_.GiveBack(iChild) + Call iLayout.AddItemToNewColumn(iChild) + Next iChildNode + + For Each iChildNode In target.children_ + Call iChildNode.data_.shape_.Resize(visResizeDirS, iLayout.AreaHeight - iChildNode.data_.shape_.CellsU("Height"), visInches) + Next iChildNode +End Function + +Private Function IncludeContainerChildren(target As CDS_NodeSH, iLayout As ContainerLayout) + Dim nLastType As TItem: nLastType = T_ITEM_PROBLEM + Dim iChildNode As CDS_NodeSH + For Each iChildNode In target.children_ + Dim iChild As Visio.Shape: Set iChild = iChildNode.data_.shape_ + Call storage_.GiveBack(iChild) + If nLastType = iChildNode.data_.type_ Then + Call iLayout.AddItem(iChild) + Else + Call iLayout.AddItemToNewColumn(iChild) + End If + nLastType = iChildNode.data_.type_ + Next iChildNode +End Function + +Private Function GroupWithChildren(target As CDS_NodeSH) As Visio.Shape + Dim iParent As Visio.Shape: Set iParent = target.data_.shape_ + Call iParent.SetCenter(originX_ + iParent.CellsU("Width") / 2#, originY_ - iParent.CellsU("Height") / 2#) + + Dim groupSel As Visio.Selection: Set groupSel = parentPage_.CreateSelection(visSelTypeEmpty) + Call groupSel.Select(iParent, visSelect) + + Dim posY As Double: posY = originY_ - iParent.CellsU("Height") + Dim maxWidth As Double: maxWidth = iParent.CellsU("Width") + + Dim iChildNode As CDS_NodeSH + For Each iChildNode In target.children_ + Dim iChild As Visio.Shape: Set iChild = iChildNode.data_.shape_ + Call storage_.GiveBack(iChild) + Call groupSel.Select(iChild, visSelect) + posY = posY - iChild.CellsU("Height") + Call iChild.SetCenter(originX_ + iChild.CellsU("Width") / 2#, posY + iChild.CellsU("Height") / 2#) + If VBA.Round(maxWidth, DEPSILON) < VBA.Round(iChild.CellsU("Width"), DEPSILON) Then _ + maxWidth = iChild.CellsU("Width") + Next iChildNode + + Dim aShape As Visio.Shape + For Each aShape In groupSel + If VBA.Round(maxWidth, DEPSILON) > VBA.Round(aShape.CellsU("Width"), DEPSILON) Then + Call aShape.Resize(visResizeDirE, maxWidth - aShape.CellsU("Width"), visInches) + End If + Next aShape + + Set GroupWithChildren = groupSel.Group +End Function + +Private Function HeightBoilerplate(target As Visio.Shape) As Double + If target.Shapes.Count < 2 Then + HeightBoilerplate = 0 + Exit Function + End If + HeightBoilerplate = target.Shapes(2).CellsU("Height") + HeightBoilerplate = HeightBoilerplate + 2 * (target.CellsU(CELLSU_CONTAINER_MARGINS) + LM_MARGINS_EPSILON) +End Function diff --git a/src/Main.bas b/src/Main.bas new file mode 100644 index 0000000..a22254f --- /dev/null +++ b/src/Main.bas @@ -0,0 +1,96 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Sub RunGenerator() + Dim thePage As Visio.Page: Set thePage = MainPage() + Call ImportDialog.Init(thePage.PageSheet.CellsU("PageHeight").Result(visMillimeters)) + Call ImportDialog.Show + If ImportDialog.isCancelled_ Then _ + Exit Sub + + Dim theData As CDS_StaticHierarchy: Set theData = ExtractData(ImportDialog.FileName) + If theData Is Nothing Then _ + Exit Sub + + If theData.nodes_.Count = 0 Then + Call UserInteraction.ShowMessage(EM_DATA_EMPTY) + Exit Sub + End If + + Call GlobalUndo.BeginScope("") + Call VsoClearPage(MainPage()) + Call GlobalUndo.EndScope + + Call GlobalUndo.BeginScope(" ") + Call CSE_ProgressBar.Init(" ", maxVal:=theData.nodes_.Count, curVal:=1) + Call CSE_ProgressBar.ShowModeless + + Dim iStorage As API_ShapeStorage + Set iStorage = CreateShapesFor(theData, MainPage()) + + Dim iManager As New LayoutManager + Call iManager.Init(theData, iStorage, originX:=0, originY:=thePage.PageSheet.CellsU("PageHeight")) + + ThisDocument.DiagramServicesEnabled = visServiceAll + + Call CSE_ProgressBar.Init(" ", maxVal:=theData.nodes_.Count, curVal:=1) + Call iManager.CombineContainers(ImportDialog.GetProps) + + Call CSE_ProgressBar.Init(" ", maxVal:=iStorage.items_.Count, curVal:=1) + Call iManager.Build(ImportDialog.GetProps) + + ThisDocument.DiagramServicesEnabled = visServiceNone + + Call Unload(CSE_ProgressBar) + Call GlobalUndo.EndScope + + Call VsoShowWholePage(thePage) + Call UserInteraction.ShowMessage(IM_GENERATION_OK, _ + theData.nodes_.Count, _ + VBA.Round(thePage.PageSheet.CellsU("PageHeight").Result(visMillimeters), 0), _ + VBA.Round(thePage.PageSheet.CellsU("PageWidth").Result(visMillimeters), 0)) +End Sub + +Public Sub ClearMain() + Call VsoClearPage(MainPage) +End Sub + +Public Sub DeleteAllPages() + Dim thePage As Visio.Page: Set thePage = MainPage() + Dim target As Visio.Page + Dim nPage&: nPage = 1 + Do While nPage <= ThisDocument.Pages.Count + Set target = ThisDocument.Pages(nPage) + If target.Name = thePage.Name Then + nPage = nPage + 1 + Else + Call target.Delete(True) + End If + Loop +End Sub + +' ==== +Private Function MainPage() As Visio.Page + Set MainPage = Application.ActiveDocument.Pages(1) +End Function + +Private Function ExtractData(targetPath$) As CDS_StaticHierarchy + Dim wrap As New API_XLWrapper + If wrap.OpenDocument(targetPath, bReadOnly:=True) Is Nothing Then _ + Exit Function + + Call CSE_ProgressBar.Init(" ", maxVal:=wrap.Document.Worksheets(1).UsedRange.Rows.Count, curVal:=2) + Call CSE_ProgressBar.ShowModeless + + On Error Resume Next + Set ExtractData = ScanExcel(wrap.Document.Worksheets(1)) + Call ProcessErrorMessages(UniqueList(ERR_XL_INVALID_TYPE)) + On Error GoTo 0 + + Call Unload(CSE_ProgressBar) + + If ExtractData Is Nothing Then _ + Call UserInteraction.ShowMessage(EM_INVALID_FILE_FORMAT) + + Call wrap.ReleaseDocument +End Function diff --git a/src/MainImpl.bas b/src/MainImpl.bas new file mode 100644 index 0000000..50b06f7 --- /dev/null +++ b/src/MainImpl.bas @@ -0,0 +1,76 @@ +Attribute VB_Name = "MainImpl" +Option Explicit + +Public Function ProcessErrorMessages(expectedErrors As Scripting.Dictionary) + If Err.Number = 0 Then _ + Exit Function + + Unload CSE_ProgressBar + If Not expectedErrors.Exists(Err.Number) Then _ + Call Err.Raise(Err.Number) + + Select Case Err.Number + Case ERR_XL_INVALID_TYPE: Call UserInteraction.ShowMessage(Err.Number, Err.Source) + End Select +End Function + +Public Function ScanExcel(target As Excel.Worksheet) As CDS_StaticHierarchy + Dim iData As New CDS_StaticHierarchy + Dim nPosition As TSubjectType + Dim iNode As CDS_NodeSH + Dim nRow&: nRow = EXCEL_FIRST_ROW + Do While target.Cells(nRow, S_ITEM_LEVEL) <> "" + Set iNode = iData.PushItem(target.Cells(nRow, S_ITEM_LEVEL)) + If iNode Is Nothing Then _ + Exit Function + Set iNode.data_ = ExtractPayload(nRow, target) + + If iNode.data_.type_ = T_ITEM_SUBJECT_TYPE Then _ + nPosition = TextToSubjectType(iNode.data_.text_) + + If iNode.rank_ >= 3 Then _ + iNode.data_.position_ = nPosition + + Call CSE_ProgressBar.IncrementA + nRow = nRow + 1 + Loop + + Set ScanExcel = iData +End Function + +Public Function CreateShapesFor(ByRef theData As CDS_StaticHierarchy, ByRef dest As Visio.Page) As API_ShapeStorage + Dim iCreator As New ShapeCreator + Call iCreator.Init(theData, dest) + Set CreateShapesFor = iCreator.CreateAllShapes() +End Function + +Public Function GetMasterFor(theType As TItem) As Visio.Master + Select Case theType + Case T_ITEM_FRONT: Set GetMasterFor = FindMaster(ThisDocument, SHAPE_FRONT) + Case T_ITEM_PROBLEM: Set GetMasterFor = FindMaster(ThisDocument, SHAPE_PROBLEM) + Case T_ITEM_SUBJECT_TYPE: Set GetMasterFor = FindMaster(ThisDocument, SHAPE_SUBJECT_TYPE) + Case T_ITEM_GROUP: Set GetMasterFor = FindMaster(ThisDocument, SHAPE_GROUP) + Case T_ITEM_ORGAN: Set GetMasterFor = FindMaster(ThisDocument, SHAPE_ORGAN) + Case T_ITEM_PERSON: Set GetMasterFor = FindMaster(ThisDocument, SHAPE_PERSON) + End Select +End Function + +' ============= +Private Function ExtractPayload(nRow&, iSource As Excel.Worksheet) As VisioNode + Dim nType As TItem: nType = TextToItemType(iSource.Cells(nRow, S_ITEM_TYPE)) + nType = TextToItemType(iSource.Cells(nRow, S_ITEM_TYPE)) + If nType = T_ITEM_UNKNOWN Then _ + Call Err.Raise(ERR_XL_INVALID_TYPE, nRow) + + Dim sText$ + If nType = T_ITEM_ORGAN Or nType = T_ITEM_PERSON Or nType = T_ITEM_GROUP Then + sText = iSource.Cells(nRow, S_ITEM_TEXT_SUBJECT) + Else + sText = iSource.Cells(nRow, S_ITEM_TEXT_THEME) + End If + + Dim iPayload As New VisioNode + Call iPayload.Init(nType, sText) + Set ExtractPayload = iPayload +End Function + diff --git a/src/PageLayout.cls b/src/PageLayout.cls new file mode 100644 index 0000000..42df683 --- /dev/null +++ b/src/PageLayout.cls @@ -0,0 +1,155 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "PageLayout" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private page_ As Visio.Page +Private props_ As PageProps + +Private originX_ As Double +Private originY_ As Double + +Private columnWidth_ As Double +Private lastColumn_ As Collection +Private columnCount_ As Long + +Private currentY_ As Double +Private currentX_ As Double + +Public Function Init(ByRef target As Visio.Page, props As PageProps) + props_ = props + Set page_ = target + + Set lastColumn_ = New Collection + columnCount_ = 0 + columnWidth_ = 0 + originX_ = 0 + originY_ = props_.height_ + + target.PageSheet.CellsU("PageHeight") = props.height_ + + currentX_ = originX_ + props_.leftGap_ + currentY_ = originY_ - PAGE_VERTICAL_GAP + If props.addHeader_ Then + Call AddTitle + currentY_ = originY_ - PAGE_TITLE_GAP + End If +End Function + +Public Function AddItem(target As Visio.Shape) + If Not CanAdd(target) Then _ + Call FinalizeColumn + Call AddShapeInternal(target) +End Function + +Public Function AddItemToNewColumn(target As Visio.Shape) + Call FinalizeColumn + Call AddShapeInternal(target) +End Function + +Public Function FinalizePage() + Call FinalizeColumn + If Not props_.multipage_ Then _ + page_.PageSheet.CellsU("PageWidth") = currentX_ +End Function + +' ================ +Private Function CanAdd(target As Visio.Shape) As Boolean + Dim newHeight As Double: newHeight = Abs(originY_ - currentY_) + target.CellsU("Height") + PAGE_VERTICAL_GAP + CanAdd = Round(newHeight, DEPSILON) < Round(props_.height_, DEPSILON) +End Function + +Private Function AddShapeInternal(target As Visio.Shape) + Dim newHeight As Double: newHeight = Abs(originY_ - currentY_) + target.CellsU("Height") + Dim newWidth As Double: newWidth = Abs(originX_ - currentX_) + target.CellsU("Width") + + Call target.SetCenter(originX_ + newWidth - target.CellsU("Width") / 2#, _ + originY_ - newHeight + target.CellsU("Height") / 2#) + currentY_ = originY_ - newHeight - PAGE_VERTICAL_GAP + If Round(target.CellsU("Width"), DEPSILON) > Round(columnWidth_, DEPSILON) Then _ + columnWidth_ = target.CellsU("Width") + + Call lastColumn_.Add(target) +End Function + +Private Function FinalizeColumn() + If lastColumn_.Count = 0 Then _ + Exit Function + + columnCount_ = columnCount_ + 1 + ' Call EqualizeWidth ' Note: do not equalize width for fronts + + If props_.multipage_ Then + Call CopyColumnToNewPage + currentX_ = originX_ + props_.leftGap_ + ElseIf props_.width_ = 0 Then + currentX_ = currentX_ + columnWidth_ + props_.columnGap_ + Else + Dim nPageCount&: nPageCount = 1 + Int(currentX_ / props_.width_) + Dim pageEdge As Double: pageEdge = originX_ + nPageCount * props_.width_ + + If columnCount_ > 1 And VBA.Round(pageEdge, DEPSILON) < VBA.Round(currentX_ + columnWidth_ + props_.leftGap_, DEPSILON) Then + Call AdjustLastColumnX(pageEdge - currentX_) + currentX_ = pageEdge + columnWidth_ + props_.columnGap_ + Else + currentX_ = currentX_ + columnWidth_ + props_.columnGap_ + End If + End If + + currentY_ = originY_ - PAGE_VERTICAL_GAP + columnWidth_ = 0 + Set lastColumn_ = New Collection +End Function + +Private Function EqualizeWidth() + Dim nItem& + Dim aShape As Visio.Shape + For nItem = 1 To lastColumn_.Count Step 1 + Set aShape = lastColumn_.Item(nItem) + If Round(columnWidth_, DEPSILON) > Round(aShape.CellsU("Width"), DEPSILON) Then + Call aShape.Resize(visResizeDirE, columnWidth_ - aShape.CellsU("Width"), visInches) + End If + Next nItem +End Function + +Private Function AddTitle() + Dim titleShape As Visio.Shape: Set titleShape = page_.Drop(FindMaster(page_.Document, SHP_TITLE), PAGE_HORIZONTAL_GAP, props_.height_ - PAGE_VERTICAL_GAP) + titleShape.CellsU("PinY") = props_.height_ - PAGE_VERTICAL_GAP - titleShape.CellsU("Height") / 2# + titleShape.CellsU("PinX") = PAGE_HORIZONTAL_GAP + titleShape.CellsU("Width") / 2# + Call lastColumn_.Add(titleShape) +End Function + +Private Function AdjustLastColumnX(xDiff As Double) + Dim nItem& + Dim aShape As Visio.Shape + For nItem = 1 To lastColumn_.Count Step 1 + Set aShape = lastColumn_.Item(nItem) + aShape.Cells("PinX") = aShape.Cells("PinX") + xDiff + Next nItem +End Function + +Private Function CopyColumnToNewPage() + Dim newPage As Visio.Page: Set newPage = page_.Document.Pages.Add + newPage.PageSheet.CellsU("PageHeight") = page_.PageSheet.CellsU("PageHeight") + If props_.width_ = 0 Then + newPage.PageSheet.CellsU("PageWidth") = currentX_ + columnWidth_ + Else + newPage.PageSheet.CellsU("PageWidth") = props_.width_ + End If + + Call SetupFixedGridPage(newPage) + + Dim aShape As Visio.Shape + For Each aShape In lastColumn_ + Call aShape.Copy(visCopyPasteNoTranslate + visCopyPasteDontAddToContainers + visCopyPasteNoCascade) + Call newPage.Paste(visCopyPasteNoTranslate + visCopyPasteDontAddToContainers + visCopyPasteNoCascade) + + Call aShape.DeleteEx(visDeleteNormal) + Next aShape +End Function diff --git a/src/ShapeCreator.cls b/src/ShapeCreator.cls new file mode 100644 index 0000000..37e639b --- /dev/null +++ b/src/ShapeCreator.cls @@ -0,0 +1,129 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ShapeCreator" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private problemIndex_ As Long +Private frontIndex_ As Long + +Private data_ As CDS_StaticHierarchy +Private storage_ As API_ShapeStorage +Private destination_ As Visio.Page + +Public Function Init(iData As CDS_StaticHierarchy, iDestination As Visio.Page) + problemIndex_ = 0 + frontIndex_ = 0 + + Set data_ = iData + Set destination_ = iDestination + Set storage_ = New API_ShapeStorage + Call storage_.Init(0, iDestination.PageSheet.Cells("PageHeight")) +End Function + +Public Function CreateAllShapes() As API_ShapeStorage + Dim iNode As CDS_NodeSH + For Each iNode In data_.nodes_ + If iNode.rank_ = 1 Then _ + Call CreateRecursive(iNode) + Next iNode + Set CreateAllShapes = storage_ +End Function + +' ======== +Private Function CreateRecursive(target As CDS_NodeSH) + Call CreateItemShape(target) + Call storage_.Store(target.data_.shape_) + Call CSE_ProgressBar.IncrementA + + If target.children_.Count = 0 Then _ + Exit Function + + Dim iChild As CDS_NodeSH + Dim iChildren As Collection: Set iChildren = OrderChildren(target) + For Each iChild In iChildren + Call CreateRecursive(iChild) + Next iChild +End Function + +Private Function CreateItemShape(ByRef target As CDS_NodeSH) + Dim iShape As Visio.Shape: Set iShape = destination_.Drop(GetMasterFor(target.data_.type_), 0, 0) + Set target.data_.shape_ = iShape + iShape.Text = target.data_.text_ + If target.data_.type_ = T_ITEM_PROBLEM Then + Call AddProblemPrefix(target, iShape) + iShape.Shapes(2).CellsU("Width") = iShape.Shapes(2).CellsU("Width") + ElseIf target.data_.type_ = T_ITEM_FRONT Then + Call AddFrontPrefix(target, iShape) + iShape.Shapes(2).CellsU("Width") = iShape.Shapes(2).CellsU("Width") + Else + Call CellsSetValue(iShape, CELLSU_POSTYPE, target.data_.position_) + iShape.CellsU("Width") = iShape.CellsU("Width") + End If +End Function + +Private Function AddProblemPrefix(iNode As CDS_NodeSH, ByRef iShape As Visio.Shape) + problemIndex_ = problemIndex_ + 1 + Dim sPrefix$: sPrefix = Fmt("{1} {2}. ", PROBLEM_PREFIX, problemIndex_) + iShape.Text = sPrefix & iShape.Text + + Dim cCursor As Visio.Characters: Set cCursor = iShape.Shapes(2).Characters + cCursor.Begin = 0 + cCursor.End = VBA.Len(sPrefix) + cCursor.CharProps(visCharacterStyle) = visBold +End Function + +Private Function AddFrontPrefix(iNode As CDS_NodeSH, ByRef iShape As Visio.Shape) + frontIndex_ = frontIndex_ + 1 + Dim sPrefix$: sPrefix = Fmt("{1} {2}. ", FRONT_PREFIX, frontIndex_) + iShape.Text = sPrefix & iShape.Text + + Dim cCursor As Visio.Characters: Set cCursor = iShape.Shapes(2).Characters + cCursor.Begin = 0 + cCursor.End = VBA.Len(sPrefix) + cCursor.CharProps(visCharacterStyle) = visBold +End Function + +Private Function OrderChildren(ByRef target As CDS_NodeSH) As Collection + If target.data_.type_ = T_ITEM_FRONT Then _ + Set target.children_ = OrderByDescendants(target.children_) ' Note: Modifying graph!! + Set OrderChildren = target.children_ +End Function + +Private Function OrderByDescendants(iInput As Collection) As Collection + Dim iDescCounts As New Scripting.Dictionary + Dim iOut As New Collection + + Dim iNode As CDS_NodeSH + Dim nDescendants& + Dim nIndex& + Dim aKey As Variant + For Each iNode In iInput + nDescendants = iNode.descendantsCount_ + If iDescCounts.Count = 0 Then + Call iOut.Add(iNode, CStr(iNode.id_)) + Call iDescCounts.Add(iNode.id_, nDescendants) + Else + nIndex = 1 + For Each aKey In iDescCounts + If iDescCounts(aKey) <= nDescendants Then _ + nIndex = nIndex + 1 + Next aKey + + Call iDescCounts.Add(iNode.id_, nDescendants) + + If nIndex > iOut.Count Then + Call iOut.Add(iNode, CStr(iNode.id_)) + Else + Call iOut.Add(iNode, CStr(iNode.id_), Before:=nIndex) + End If + End If + Next iNode + + Set OrderByDescendants = iOut +End Function diff --git a/src/VisioNode.cls b/src/VisioNode.cls new file mode 100644 index 0000000..bda39f7 --- /dev/null +++ b/src/VisioNode.cls @@ -0,0 +1,22 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "VisioNode" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'------------ Payload for Hierarchy node --------------- +Option Explicit + +Public type_ As TItem +Public position_ As TSubjectType +Public text_ As String +Public shape_ As Visio.Shape + +Public Function Init(nType As TItem, sText$, Optional nPosition As TSubjectType = T_SUBJECT_UNKNOWN) + type_ = nType + text_ = sText + position_ = nPosition +End Function diff --git a/src/z_UIMessages.bas b/src/z_UIMessages.bas new file mode 100644 index 0000000..7d55819 --- /dev/null +++ b/src/z_UIMessages.bas @@ -0,0 +1,68 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + EM_XL_INVALID_TYPE = ERR_XL_INVALID_TYPE + EM_VALIDATION_FAIL + EM_DATA_EMPTY + EM_INVALID_FILE_FORMAT + + IM_GENERATION_OK + + ' QM_CLEAR_BEFORE_READD +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_VALIDATION_FAIL + Call MsgBox(" ", vbExclamation) + Case EM_DATA_EMPTY + Call MsgBox("Data is empty", vbExclamation) + Case EM_INVALID_FILE_FORMAT + Call MsgBox("Invalid file format", vbExclamation) + Case EM_XL_INVALID_TYPE + Call MsgBox(Fmt(" {1}", params), vbExclamation) + + Case IM_GENERATION_OK + Call MsgBox(Fmt("Generation complete" & vbNewLine & _ + "Elements count: {1}" & vbNewLine & _ + "Page size: {2} x {3} mm^2", unwrapped), vbInformation) + + Case Else + Call MsgBox("Invalid message code", vbCritical) + End Select +End Function + +Public Function UIAskQuestion(theCode As MsgCode, ParamArray params() As Variant) As Boolean + Dim unwrapped As Variant: unwrapped = params + unwrapped = FixForwardedParams(unwrapped) + + Dim answer&: answer = vbNo + Select Case theCode + ' Case QM_CLEAR_BEFORE_READD + ' 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..afff2c8 --- /dev/null +++ b/src/z_UIRibbon.bas @@ -0,0 +1,10 @@ +Attribute VB_Name = "z_UIRibbon" +Option Explicit + +Public Sub OnRibbonBtn(iControl As IRibbonControl) + Select Case iControl.ID + Case "LoadExcel": Call RunGenerator + Case "ClearMain": Call ClearMain + Case "DeletePages": Call DeleteAllPages + 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..839fa3c --- /dev/null +++ b/ui/customUI1.xml @@ -0,0 +1,26 @@ + + + + + + +