пятница, 22 августа 2014 г.

Интерактивные методы. Часть 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
    Next
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
        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

Комментариев нет:

Отправить комментарий