Schöck
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Опять про печать из модели нескольких листов

Опять про печать из модели нескольких листов

Ответ
Поиск в этой теме
Непрочитано 12.03.2009, 11:02 #1
Опять про печать из модели нескольких листов
gizmo_zx
 
Проектировщик ЭО,ЭМ, ЭОС
 
Нижний Новгород
Регистрация: 18.07.2007
Сообщений: 234

подсобите пожалуйсто с программкой печати из модели нескольких страниц.

програмку взял здесь: http://dwg.ru/dnl/1851
можно поправить сортировку не по таблице а по атрибуту "num" блока "ramka", думаю это где-то здесь.
помогите

Код:
[Выделить все]
Sub SelectLimits(Optional opt As Byte)

Dim pSS As AcadSelectionSet
Dim pE As AcadEntity
Dim pLin As AcadLine
Dim pCir As AcadCircle
Dim pNLin As Long, pNCir As Long, pNOther As Long
Dim pTable As AcadTable
Dim pLWPLine As AcadLWPolyline

Dim minX, minY, maxX, maxY As Double

Dim pV As Variant
Dim I As Double 'КОЛ-ВО выбранных прямых
'Dim TableCount
Dim Number As Long
Dim C1, C2, C3, J, K As Long
Dim pLayer As String
Dim TablePos As Variant '(0 To 1) As Double

ReDim LimitsArray(0 To 200)
ReDim TablesArray(0 To 200)
I = 0
J = 0

pLayer = UCase(UserForm1.TextBox1.Text)


    PrepareSelSet ThisDrawing, "ss", pSS
    PrintMessage vbCrLf & "Выбери объекты:"
    pSS.SelectOnScreen
    If pSS.Count = 0 Then
        PrintMessage " Ничего не выбрано."
        Exit Sub
    End If
    'ReDim ArrayOfTable(pSS.Count)
    'PrintMessage vbCrLf & "***********************************************"
    For Each pE In pSS
        'If pLayer = UCase(pLine.Layer)
        Select Case TypeName(pE)
        Case "IAcadTable2"
            Set pTable = pE
            If pLayer = UCase(pTable.Layer) Then
                I = I + 1
                Set TablesArray(I) = pTable
            End If
            'For J = 1 To pTable.Rows
            '    ArrayOfTable(I).Col1(J) = pTable.GetText(J, C1)
            '    ArrayOfTable(I).Col2(J) = pTable.GetText(J, C2)
            '    ArrayOfTable(I).Col3(J) = pTable.GetText(J, C3)
            'Next
            'pTable.InsertionPoint
            
            
        Case "IAcadLWPolyline"
            Set pLWPLine = pE
            If pLayer = UCase(pLWPLine.Layer) Then
                If UBound(pLWPLine.Coordinates) = 7 Or UBound(pLWPLine.Coordinates) = 9 Then
                    J = J + 1
                    With pLWPLine
                        minX = .Coordinates(0)
                        minY = .Coordinates(1)
                        maxX = minX
                        maxY = minY
                        For K = 0 To UBound(.Coordinates) - 1
                            If minX > .Coordinates(K) Then minX = .Coordinates(K)
                            If minY > .Coordinates(K + 1) Then minY = .Coordinates(K + 1)
                            If maxX < .Coordinates(K) Then maxX = .Coordinates(K)
                            If maxY < .Coordinates(K + 1) Then maxY = .Coordinates(K + 1)
                            K = K + 1
                        Next
                    End With
                    'Проверяем нет ли уже такой рамки в наборе
                    If J = 1 Then
                        LimitsArray(J).p1(0) = minX: LimitsArray(J).p1(1) = minY
                        LimitsArray(J).p2(0) = maxX: LimitsArray(J).p2(1) = maxY
                    End If
                    For K = 1 To J - 1
                        If LimitsArray(K).p1(0) = minX And LimitsArray(K).p1(1) = minY And _
                            LimitsArray(K).p2(0) = maxX And LimitsArray(K).p2(1) = maxY Then
                            J = J - 1
                            Exit For
                        End If
                        If K = J - 1 Then 'Если нет то заносим
                            LimitsArray(J).p1(0) = minX: LimitsArray(J).p1(1) = minY
                            LimitsArray(J).p2(0) = maxX: LimitsArray(J).p2(1) = maxY
                        End If
                    Next
                End If
            End If
        'Case Else
        '    pNOther = pNOther + 1
        '    MsgBox TypeName(pE)
        End Select
    Next pE
    ReDim Preserve TablesArray(I)
    ReDim Preserve LimitsArray(J)
    pSS.Delete
    
    If I <> J Then
        If MsgBox("колво рамок и осн. надписей не совпадает: " & J & " рамок, " & I & " осн. надписей" & " Печатать дальше?", vbOKCancel) = vbCancel Then
            Exit Sub
        End If
    End If
    'Сортировка таблиц по номерам
    '
    C1 = 0
    
    For K = 1 To I - 1
        With UserForm1
            'C2 = CLng(TablesArray(K).GetText(CLng(.TextBox12.Value) - 1, CLng(.TextBox13.Value) - 1))
            For L = K + 1 To I
                C2 = CLng(TablesArray(K).GetText(CLng(.TextBox12.Value) - 1, CLng(.TextBox13.Value) - 1))
                C3 = CLng(TablesArray(L).GetText(CLng(.TextBox12.Value) - 1, CLng(.TextBox13.Value) - 1))
                If C2 > C3 Then
                    Set pTable = TablesArray(K)
                    Set TablesArray(K) = TablesArray(L)
                    Set TablesArray(L) = pTable
                End If
            Next
        End With
    Next
    For K = 1 To I - 1
        With UserForm1
            C2 = CLng(TablesArray(K).GetText(CLng(.TextBox12.Value) - 1, CLng(.TextBox13.Value) - 1))
        End With
    Next
    'Печать
    If UserForm1.CheckBox3.Value Then ' печатать по номерам листов
        For K = 1 To I 'Перебираем таблицы
            TablePos = TablesArray(K).InsertionPoint
            For L = 1 To J ' перебираем рамки
                With LimitsArray(L)
                    If .p1(0) <= TablePos(0) And .p2(0) >= TablePos(0) And _
                        .p1(1) <= TablePos(1) And .p2(1) >= TablePos(1) Then
                        PlotFile .p1, .p2
                        .Plotted = True
                        Exit For
                    End If
                    'If L = J Then PlotFile .p1, .p2 ' если ни одна таблица не попала в рамку, то печатаем
                End With
            Next
        Next
        If I <> J Then
            For L = 1 To J
                With LimitsArray(L)
                    If Not .Plotted Then
                        PlotFile .p1, .p2
                    End If
                End With
            Next
        End If
    Else
        For L = 1 To J ' перебираем рамки
            With LimitsArray(L)
                If .p1(0) <= TablePos(0) And .p2(0) >= TablePos(0) And _
                    .p1(1) <= TablePos(1) And .p2(1) >= TablePos(1) Then
                    PlotFile .p1, .p2
                End If
            End With
        Next
    End If
    'CalculateSpecification
End Sub
Просмотров: 3852
 
Непрочитано 12.03.2009, 11:14
#2
Sazanoff_e

А я тут это...погулять вышел...
 
Регистрация: 28.03.2007
Москва - от слова Моск?
Сообщений: 227
<phrase 1=


Offtop: Ужос! Как только люди не изворачиваются, лишь бы с "листами" не связываться
__________________
Рожденный проектировать ГОСТов не читает. (с)Туманов А.А.
Sazanoff_e вне форума  
 
Автор темы   Непрочитано 28.09.2010, 12:33
#3
gizmo_zx

Проектировщик ЭО,ЭМ, ЭОС
 
Регистрация: 18.07.2007
Нижний Новгород
Сообщений: 234
<phrase 1= Отправить сообщение для gizmo_zx с помощью Skype™


Добрый день.
Есть вопрос по печати экрана:
Код:
[Выделить все]
PlotFile .p1, .p2. Plotted = True
Хотелось бы задать количество копий.
Сейчас гоняю команду в цикле, но процесс долгий. Хотелось бы ускорить.
Пять копий заданные в настройках печати, отправляется в два раза быстрее чем Plotted пять раз в цикле.
gizmo_zx вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Опять про печать из модели нескольких листов

Инженерная школа
Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Опять про перепуск арматуры AlfF1 Железобетонные конструкции 52 14.11.2017 08:55
опять про Layout... тинатаки AutoCAD 3 13.06.2006 16:22
Опять про XP SP2 Андрей С. AutoCAD 7 16.03.2005 13:15
Опять про исчезающие тулбары Startrek Программирование 2 03.01.2005 16:53