Initial commit
This commit is contained in:
IRBorisov
commit
bb026464a0
37
VBAMake.txt
Normal file
37
VBAMake.txt
Normal file
|
|
@ -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
|
||||
BIN
distr/!Реестр противоречий.xlsm
Normal file
BIN
distr/!Реестр противоречий.xlsm
Normal file
Binary file not shown.
BIN
distr/Версии/Без фронтов/!Карта субъектов.vsdm
Normal file
BIN
distr/Версии/Без фронтов/!Карта субъектов.vsdm
Normal file
Binary file not shown.
BIN
distr/Версии/Без фронтов/Пример входных данных.xlsx
Normal file
BIN
distr/Версии/Без фронтов/Пример входных данных.xlsx
Normal file
Binary file not shown.
BIN
distr/Пример входных данных.xlsx
Normal file
BIN
distr/Пример входных данных.xlsx
Normal file
Binary file not shown.
80
script/manifest.txt
Normal file
80
script/manifest.txt
Normal file
|
|
@ -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
|
||||
BIN
skeleton/!Карта субъектов.vsdm
Normal file
BIN
skeleton/!Карта субъектов.vsdm
Normal file
Binary file not shown.
BIN
skeleton/Карта субъектов.vsdx
Normal file
BIN
skeleton/Карта субъектов.vsdx
Normal file
Binary file not shown.
132
src/ContainerLayout.cls
Normal file
132
src/ContainerLayout.cls
Normal file
|
|
@ -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
|
||||
52
src/DataAcces.bas
Normal file
52
src/DataAcces.bas
Normal file
|
|
@ -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
|
||||
|
||||
116
src/Declarations.bas
Normal file
116
src/Declarations.bas
Normal file
|
|
@ -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
|
||||
22
src/DevHelper.bas
Normal file
22
src/DevHelper.bas
Normal file
|
|
@ -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
|
||||
75
src/ImportDialog.frm
Normal file
75
src/ImportDialog.frm
Normal file
|
|
@ -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
|
||||
BIN
src/ImportDialog.frx
Normal file
BIN
src/ImportDialog.frx
Normal file
Binary file not shown.
200
src/LayoutManager.cls
Normal file
200
src/LayoutManager.cls
Normal file
|
|
@ -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
|
||||
96
src/Main.bas
Normal file
96
src/Main.bas
Normal file
|
|
@ -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
|
||||
76
src/MainImpl.bas
Normal file
76
src/MainImpl.bas
Normal file
|
|
@ -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
|
||||
|
||||
155
src/PageLayout.cls
Normal file
155
src/PageLayout.cls
Normal file
|
|
@ -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
|
||||
129
src/ShapeCreator.cls
Normal file
129
src/ShapeCreator.cls
Normal file
|
|
@ -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
|
||||
22
src/VisioNode.cls
Normal file
22
src/VisioNode.cls
Normal file
|
|
@ -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
|
||||
68
src/z_UIMessages.bas
Normal file
68
src/z_UIMessages.bas
Normal file
|
|
@ -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
|
||||
10
src/z_UIRibbon.bas
Normal file
10
src/z_UIRibbon.bas
Normal file
|
|
@ -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
|
||||
2
ui/.rels
Normal file
2
ui/.rels
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
|
||||
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships"><Relationship Id="rId3" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/thumbnail" Target="docProps/thumbnail.emf"/><Relationship Id="rId2" Type="http://schemas.microsoft.com/office/2007/relationships/ui/extensibility" Target="visio/customUI/customUI1.xml"/><Relationship Id="rId1" Type="http://schemas.microsoft.com/visio/2010/relationships/document" Target="visio/document.xml"/><Relationship Id="rId6" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties" Target="docProps/custom.xml"/><Relationship Id="rId5" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Target="docProps/app.xml"/><Relationship Id="rId4" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Target="docProps/core.xml"/></Relationships>
|
||||
26
ui/customUI1.xml
Normal file
26
ui/customUI1.xml
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
<?xml version="1.0" encoding="utf-8"?>
|
||||
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
|
||||
<ribbon>
|
||||
<tabs>
|
||||
<tab id="tab1" label="КАРТА СУБЪЕКТОВ">
|
||||
<group id="group1" label="Загрузка">
|
||||
<button id="LoadExcel" size="large"
|
||||
label="Импорт"
|
||||
supertip="Загрузка из Excel"
|
||||
imageMso="FileSaveAsExcelXlsx"
|
||||
onAction="OnRibbonBtn"/>
|
||||
<button id="ClearMain" size="large"
|
||||
label="Очистка"
|
||||
supertip="Очистить основной лист"
|
||||
imageMso="AccessRecycleBin"
|
||||
onAction="OnRibbonBtn"/>
|
||||
<button id="DeletePages" size="large"
|
||||
label="Удалить страницы"
|
||||
supertip="Удалить все дополнительные страницы"
|
||||
imageMso="BroadcastEnd"
|
||||
onAction="OnRibbonBtn"/>
|
||||
</group>
|
||||
</tab>
|
||||
</tabs>
|
||||
</ribbon>
|
||||
</customUI>
|
||||
Loading…
Reference in New Issue
Block a user