VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "ImportManager" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private out_ As Visio.Page Private inLaws_ As Excel.Worksheet Private inLinks_ As Excel.Worksheet Private params_ As ItemImportOptions Private layout_ As LayoutManager Public nLaws_ As Long Public nLinks_ As Long Public Function Init(iSource As Excel.Workbook, iDestination As Visio.Page, iUserInput As ItemImportOptions) nLaws_ = 0 nLinks_ = 0 Set out_ = iDestination Set inLaws_ = iSource.Sheets(1) Set inLinks_ = iSource.Sheets(2) Set params_ = iUserInput Set layout_ = New LayoutManager Call layout_.Init(iDestination, iUserInput) End Function Public Function GenerateSchema() As Boolean Call CSE_ProgressBar.Init("Загрузка данных", "Добавление документов...", maxVal:=CDbl(inLaws_.UsedRange.Rows.Count)) Call CSE_ProgressBar.ShowModeless nLaws_ = XLLoadDocuments() If params_.links_ Then Call CSE_ProgressBar.Init(CSE_ProgressBar.Title, "Загрузка связей...", maxVal:=CDbl(inLinks_.UsedRange.Rows.Count)) nLinks_ = XLLoadLinks() End If Call Unload(CSE_ProgressBar) End Function ' ================= Private Function XLLoadDocuments() As Long Dim newShape As Visio.Shape Dim nRow&: nRow = XL_FIRST_LINE Do While inLaws_.Cells(nRow, DS_ID) <> vbNullString Set newShape = layout_.AddNewShape(inLaws_.Cells(nRow, DS_LEVEL)) With newShape .Name = "N" & inLaws_.Cells(nRow, DS_ID) .Text = TrimDocTitle(inLaws_.Cells(nRow, DS_TITLE)) End With Call CSE_ProgressBar.IncrementA nRow = nRow + 1 Loop XLLoadDocuments = nRow - XL_FIRST_LINE End Function Private Function XLLoadLinks() As Long Dim nRow&: nRow = XL_FIRST_LINE Dim newShape As Visio.Shape Do While inLinks_.Cells(nRow, LS_SOURCE) <> vbNullString Dim sSource$: sSource = "N" & inLinks_.Cells(nRow, LS_SOURCE) Dim sDest$: sDest = "N" & inLinks_.Cells(nRow, LS_TARGET) Dim iSource As Visio.Shape: Set iSource = out_.Shapes(sSource) Dim iDestination As Visio.Shape: Set iDestination = out_.Shapes(sDest) Set newShape = out_.Drop(FindMaster(ThisDocument, MASTER_CONNECTOR), 0, 0) With newShape .CellsU(CELLSU_LNKTYPE) = inLinks_.Cells(nRow, LS_TYPE) Call .CellsU("BeginX").GlueTo(iSource.CellsU("PinX")) Call .CellsU("EndX").GlueTo(iDestination.CellsU("PinX")) End With Call CSE_ProgressBar.IncrementA nRow = nRow + 1 Loop XLLoadLinks = nRow - XL_FIRST_LINE End Function Private Function TrimDocTitle(sTitle$) As String Dim sTxt$: sTxt = sTitle If VBA.Len(sTxt) >= MAX_TITLE_LEN Then sTxt = VBA.Left(sTxt, MAX_TITLE_LEN) sTxt = VBA.StrReverse(sTxt) sTxt = VBA.Mid(sTxt, VBA.InStr(sTxt, " ") + 1) sTxt = VBA.StrReverse(sTxt) & " ..." End If TrimDocTitle = sTxt End Function