|
| | |
| | |
|

Для русскоязычных пользователей Visio. Начинающих и профессионалов. Где взять, как сделать, что купить и т.д.

Интерактивные методы. Часть 2. Фрагмент программы

Это приложение к предыдущей статье Интерактивные методы размещения данных. Для интересующихся конкретной реализацией.

Полностью программа здесь не приводится. Дело в том, что сама по себе задача формирования перечня элементов по ЕСКД достаточно сложна. Там несколько уровней вложенной сортировки. Плюс разные особенности с группировкой данных. Да еще и реализацию пришлось делать двухступенчатой: один экзешник выбирает данные о составе из PDM-системы и сбрасывает их в XML-файл; другой работает чисто на форматирование - принимает данные из XML и выводит в Visio.

Ниже приводятся основные фрагменты из второй, форматирующей части.

Функции Proc1 и Proc2 - обработчики меню для вывода "в глубину" и "в ширину". Практически одинаковые и обращаются к одной и той же процедуре DrawCollection, только с разными параметрами.

DrawCollection в зависимости от режима создает новую страницу либо через процедуру SiblPage (когда страницы наращиваются вбок), либо через AddPage (когда нужно создать физическую страницу).

А реальное заполнение страницы идет через одну и ту же процедуру WriteCurrRow_2.

'Форматирование вывода по умолчанию. Автомат.

Function Proc1() As Integer

Proc1 = -1 'Неопознанная ошибка

On Error GoTo Proc1Err

AddLog "Создаем Visio.Application - " & Now

Set VSo = CreateObject("Visio.Application")

AddLog "Создаем документ по шаблону - " & Now

Set VSdoc = VSo.Documents.Add(ApplicationPath & "\PE3-v3.vst")

DrawCollection 1

AddPage "Lr" 'Последняя страница - "лист регистрации изменений"

Proc1 = 0 'Нормальное завершение

Proc1Err:

On Error Resume Next

Set VSdoc = Nothing

Set VSo = Nothing

End Function

'Форматирование лентой. Интерактивная нарезка

Function Proc2() As Integer

Proc2 = -1 'Неопознанная ошибка

On Error GoTo Proc2Err

AddLog "Создаем Visio.Application - " & Now

Set VSo = CreateObject("Visio.Application")

AddLog "Создаем документ по шаблону - " & Now

Set VSdoc = VSo.Documents.Add(ApplicationPath & "\PE3-v3.vst")

DrawCollection 2

Proc2 = 0 'Нормальное завершение

Exit Function

Proc2Err:

On Error Resume Next

Set VSdoc = Nothing

Set VSo = Nothing

End Function

Sub DrawCollection(ByVal Md As Integer)

Set ListCollection = New Collection 'Создается коллекция листов перечня

Set tmpListItm = New ListIt

tmpListItm.XPos = (420 + 20) * (ListCollection.Count) / 50.8

tmpListItm.YPos = 292 / 50.8

ListCollection.Add tmpListItm

CurrList = ListCollection.Count

AddLog "Заполняем штамп первого листа - " & Now

WriteFirstPageData 'Заполнение штампов первого листа

CriticalErorr = False

nList = 1

For i = 1 To peMain.OutColl.Count

WriteCurrRow_2 peMain.OutColl(i), i, 1

If PageFull Then 'Получено сообщение о достижении конца текущей страницы

'UndoRow 'Отмена не уместившейся строки

nList = nList + 1

If Md = 1 Then

CreateNextPage 'Второй лист на следующей странице

Else

SiblPage 'Создание бланка "Второй лист" справа на том же листе

End If

'AddPage

WriteCurrRow_2 peMain.OutColl(i), i, 1

End If

' If CriticalErorr Then GoTo Proc2Err

End Sub

'Добавить страницу справа на том же листе

Public Sub SiblPage()

Dim Bl As Visio.Master

Set Bl = VSdoc.Masters("Blank2")

Set ShBlank = VSo.ActivePage.Drop(Bl, 202 / 50.8 + (420 + 20) * (nList - 1) / 50.8, 292 / 50.8)

WriteNextPageData 2

End Sub

Private Sub AddPage(ByVal Mast As String)

Dim oPage As Visio.Page

Dim Bl As Visio.Master

Dim ShBlank As Visio.Shape

Set oPage = VSdoc.Pages.Add

Set Bl = VSdoc.Masters(Mast)

Set ShBlank = VSo.ActivePage.Drop(Bl, 202 / 50.8, 292 / 50.8)

End Sub

Private Sub WriteCurrRow_2(ByVal Nd As Object, ByVal id As Integer, LineMode As Integer)

Dim shpObj As Visio.Shape

'На листе есть ограничивающая координата. Если шейп после заполнения текстом пересекает ее,

'он выбрасывается и лист считается заполненным.

On Error GoTo StructError

Set pagObj = VSo.ActivePage

' x = pagObj.Shapes("Title").Cells("PinX") 'Большого значения не имеет, так как потом все равно подвинется при привязке

x = ListCollection(ListCollection.Count).XPos + 17 / 25.4

If Nd.rType = 1 Then

Set mastObj = VSdoc.Masters("Row")

Set shpObj = pagObj.Drop(mastObj, x, CurrentPos)

shpObj.Cells("Prop.rowID") = id

If (Nd.Prim = "") Or (InStr(1, Nd.Prim, "Из состава") > 0) Then

shpObj.Shapes(1).Text = Nd.PozOboz

Else

shpObj.Shapes(1).Text = Nd.PozOboz & "*"

End If

shpObj.Shapes(2).Text = Nd.Naimen

shpObj.Shapes(3).Text = Nd.Kol

shpObj.Shapes(4).Text = Nd.Prim

Else

Set mastObj = VSdoc.Masters("RowCentr")

Set shpObj = pagObj.Drop(mastObj, x, CurrentPos)

shpObj.Cells("Prop.rowID") = id

shpObj.Shapes(1).Text = ""

shpObj.Shapes(2).Text = Nd.Zag

shpObj.Shapes(3).Text = ""

shpObj.Shapes(4).Text = ""

End If

'Проверка, не опустился ли новый шейп ниже ограничителя

DoEvents 'Замедляет процесс, но без этого многострочные элементы не успевают развернуться до анализа переполнения

tmpPos = CurrentPos - shpObj.Cells("Height")

If LineMode = 1 Then

If ListCollection.Count > 1 Then

If tmpPos < BottomNext / 25.4 Then 'Проверка на переполнение

shpObj.Delete

PageFull = True

Exit Sub

End If

Else

If tmpPos < BottomFirst / 25.4 Then

shpObj.Delete

PageFull = True

Exit Sub

End If

Else

End If

'Присоединить новый шейп к предыдущему, нарастить коллекцию и сместить текущую позицию

If PageRows.Count > 0 Then

Set PrecShp = PageRows.Item(PageRows.Count)

ConnShRow shpObj, PrecShp

End If

PageRows.Add shpObj

CurrentPos = shpObj.Cells("PinY") - shpObj.Cells("Height") 'Низ последнего шейпа

'Забрасывать шейп в коллекцию шейпов лучше здесь, когда уже точно ясно, что он останется.

ListCollection(CurrList).RowColl.Add shpObj 'Добавили вновь созданный шейп к коллекции шейпов листа

Exit Sub

StructError:

MsgBox "Ошибка в структуре входного файла"

CriticalErorr = True

End Sub