[tujn08]

Привет!
Печать чертежей(по определенным правилам) из вкладок Модель Лист1 и тд.

В каждой вкладке может быть неограниченное количество листов чертежей(500 шт. к примеру) разных форматов А0 А1 А2 А3 А4 и нестандартные.

Функции:
1) Необходима печать на выбранные МФУ на соответствующих форматах.
2) выбор количества копий
3) печать в PDF
4) "печать"(500 листов) в отдельные файлы .dwg (1 чертеж= 1 файл)
5) аналогично п.4 для PDF
6) печать блоками. 500 листов разбиты на блоки между блоками от 40мм расстояния по Х и У - аналогично п.4 блок в отдельный файл.
Чертежи расставлены в виде матрицы (строки и столбцы), но не строго друг над другом. Расстояние между чертежами до 30мм.
7) печать на несколько МФУ блоками (что бы распечатанные листы были распечатаны в соответствии с составленными матрицами - построчно или по столбцам.)

Есть готовый принтсервер который требуется допилить:
1) печатает только с вкладки Модель
2) количество копий отправляет не свойством, а количеством раз. (не один раз в 6 копиях, а 6 раз по 1 копии)
3) печать блоками не предусмотренная (в Модель есть 60 блоков - для правильной печати надо 60 раз выбирать блок + печать замедляется если больше 1 копии)
4) печать блока в отдельный файл DWG не предусмотрена
5) печать чертежей блока в разные файлы DWG не предусмотрена
6) печать нестандартных форматов
и еще несколько моментов для определения области печати.

----- добавлено через ~2 мин. -----
Так же кому не жалко - мне нужен список операторов автокада с описанием на русском и примером. Или VBA на русском.

[Кулик Алексей aka kpblc]

Вариантов несколько:
1. Найти готовое решение, изучить язык программирования, проанализироавть код и изменить его.
2. Найти готовое решение и изменить условия своей задачи так, чтобы они соответствовали готовому решению
3. Обратиться в раздел "Поиск исполнителей"
4. Заказать ПО у стороннего разработчика.

[maratovich]

Сообщение от tujn08 Так же кому не жалко - мне нужен список операторов автокада с описанием на русском и примером. Или VBA на русском.

Непонятно :
1. Вы ищите кто доделает Вашу программу ? (тогда где исходник)
2. Предлагаете сделать то что Вам надо ? (надо искать исполнителя)
3. Вы ищите готовое решение ? Так оно уже давно есть, под все Ваши потребности.

[tujn08]

Сообщение от maratovich 3. Вы ищите готовое решение ? Так оно уже давно есть, под все Ваши потребности.

И где это готовое решение?

Мне нужен либо тот кто доделает макрос под мои потребности.
Либо поможет доделать дав список команд или готовые программы которые можно объединить, что бы все было как требуется.

http://www.engineerbox.ru/page/autocad-pechat-iz-modeli исходник макроса.

Код:

[Выделить все]

Const ver = "2.5.1.4.9"
' 14.04.2013
Type LimitType
    p1(0 To 2) As Double
    p2(0 To 2) As Double
    Plotted As Boolean
End Type

Global MediaArray() As Variant
Global LocalMediaArray() As Variant
Global i_odd As Integer
Dim LimitsArray() As LimitType ' Массив Рамок
Dim TablesArray() As AcadTable 'IAcadTable2 ' массив основных надписей
Dim TextArray() As LimitType

Sub StartPlot()
  On Error Resume Next
  Plot_U.Caption = "!U_Plot версия " & ver & " - макрос автоматической печати "
  Plot_U.Show
End Sub
Sub StartPlotAutomatic()
    SelectLimits True
End Sub
Sub PlotFile(p1 As Variant, p2 As Variant)
    On Error Resume Next
    Dim oPlot As AcadPlot
    Dim PlotConfig As AcadPlotConfigurations
    Dim AddedLayouts() As String
    Dim LayoutList As Variant
    Dim layout As AcadLayout
    Dim point1, point2 As Variant
    Dim a As Integer, b As Integer
    Dim pSS As AcadSelectionSet
    Dim formatx As Double, formaty As Double, delit As Double
    Dim re1 As AcadLWPolyline

    Dim newValue(0 To 1) As Double
   
    ReDim Preserve AddedLayouts(1 To 1)
    point1 = p1 ': point1(1) = p1(1)
    point2 = p2 '(0) = p2(0): point2(1) = p2(1)
    ReDim Preserve point1(0 To 1)
    ReDim Preserve point2(0 To 1)
    AddedLayouts(1) = ThisDrawing.ActiveLayout.Name ' ActiveLayout
    LayoutList = AddedLayouts
    Set oPlot = ThisDrawing.Plot
    Set PlotConfig = ThisDrawing.PlotConfigurations
    Set layout = ThisDrawing.ModelSpace.layout
    
    layout.PlotType = acWindow
    layout.SetWindowToPlot point1, point2
        
    a = 0
    b = 0
    x1 = point1(0)
    y1 = point1(1)
    x2 = point2(0)
    y2 = point2(1)
    bOneToOne = Plot_U.CB_OneToOne.Value
    deltaramok = Val(Plot_U.TB_deltaramok.Text) / 100
    formaty = point2(1) - point1(1)
    formatx = point2(0) - point1(0)
    vertic = IIf(formaty > formatx, 1, 0)   ' вертикально или горизонтально расположен лист
    If bOneToOne Then
        ' A4, A3, A2, A1, A0
        arr_wd = Array(210, 297, 420, 594, 841)
        arr_hd = Array(297, 420, 594, 841, 1189)
    Else
        arr_wd = Array(210, 297)
        arr_hd = Array(297, 420)
    End If
    
    For I = 0 To UBound(arr_wd)
        ' если вертикальный чертеж
        If (vertic) Then
            modk1 = formaty Mod arr_hd(I)
            modk2 = formatx Mod arr_wd(I)
            If modk1 <> 0 Then
                formaty = IIf(Abs(1 - modk1 * arr_hd(I) / formaty) < deltaramok, arr_hd(I) * modk1, formaty)
            Else
                formaty = IIf(Abs(1 - arr_hd(I) / formaty) < deltaramok, arr_hd(I), formaty)
            End If
            If modk2 <> 0 Then
                formatx = IIf(Abs(1 - modk2 * arr_wd(I) / formatx) < deltaramok, arr_wd(I) * modk2, formatx)
            Else
                formatx = IIf(Abs(1 - arr_wd(I) / formatx) < deltaramok, arr_wd(I), formatx)
            End If
            k1 = formaty / arr_hd(I)
            k2 = formatx / arr_wd(I)
            If (Abs(1 - k1 / k2) < 0.00001) Then
                delit = formaty / arr_hd(I)
                If (Abs(1 - formaty / delit / arr_hd(I)) <= 0.02) Then r = 4 - I
                If bOneToOne And formaty <= arr_hd(I) Then Exit For
            End If
            
        Else
            modk1 = formaty Mod arr_wd(I)
            modk2 = formatx Mod arr_hd(I)
            If modk1 <> 0 Then
                formaty = IIf(Abs(1 - modk1 * arr_wd(I) / formaty) < deltaramok, arr_wd(I) * modk1, formaty)
            Else
                formaty = IIf(Abs(1 - arr_wd(I) / formaty) < deltaramok, arr_wd(I), formaty)
            End If
            If modk2 <> 0 Then
                formatx = IIf(Abs(1 - modk2 * arr_hd(I) / formatx) < deltaramok, arr_hd(I) * modk2, formatx)
            Else
                formatx = IIf(Abs(1 - arr_hd(I) / formatx) < deltaramok, arr_hd(I), formatx)
            End If
            k1 = formaty / arr_wd(I)
            k2 = formatx / arr_hd(I)
            If (Abs(1 - k1 / k2) < 0.00001) Then
                delit = formaty / arr_wd(I)
                If (Abs(1 - formaty / delit / arr_wd(I)) <= 0.02) Then r = 4 - I
                If bOneToOne And formaty <= arr_wd(I) Then Exit For
            End If
        End If
    Next
    Select Case r
    Case 4:
        a = 1
        b = 1
    Case 3:
        a = 2
        b = 1
    Case 2:
        a = 1
        b = 2
    Case 1:
        a = 2
        b = 2
    Case 0:
        a = 0
        b = 0
    End Select

    ' учитывается какой принтер на печати
    usePrinter = 1
    ' если использован 2 принтер
    If Plot_U.CB_USESECONDPRINTER.Value Then
       ' если отмечен чекбокс для переворота PDF
       If Plot_U.CB_PRINTODDPAGE.Value Then
          If i_odd Mod 2 = 0 Then usePrinter = 2
       End If
       ' если отмечен чекбокс печать крупных форматов во 2 принтере
       If Plot_U.CB_PRINTBIGFORMAT.Value Then
          If bOneToOne And a & b <> "11" And a & b <> "21" Then usePrinter = 2
       End If
       If Plot_U.CB_ROTATEPDFPRINTER.Value And vertic = 0 Then
          usePrinter = 2
       End If
    End If
    
    If Plot_U.CB_SPECFORMAT.Value And usePrinter = 1 Then
       layout.CanonicalMediaName = WhatIsMyCanonicalMediaName(Plot_U.TB_SPECFORMAT.Text)
    ElseIf Plot_U.CB_SPECFORMAT2.Value And usePrinter = 2 Then
       layout.CanonicalMediaName = WhatIsMyCanonicalMediaName(Plot_U.TB_SPECFORMAT2.Text)
    Else
        GetPaperSize layout, a, b
    End If
    change_Target
    
    ' по умолчанию считается, что принтер печатает в книжном варианте
    ' если чертеж вертикальный, то не надо поворачивать (только если отразить)
    ' если чертеж горизонтальный, то надо повернуть на 90 (либо отразить на 270)
    If Not Plot_U.CB_ROTATEPDFPRINTER.Value Then
        If (vertic = 1) Then
            layout.PlotRotation = IIf(Plot_U.CB_OVERTURN, ac90degrees, ac270degrees)
            'layout.PlotRotation = IIf(Plot_U.CB_OVERTURN, ac180degrees, ac0degrees)
        Else
            layout.PlotRotation = IIf(Plot_U.CB_OVERTURN, ac180degrees, ac0degrees)
            'layout.PlotRotation = IIf(Plot_U.CB_OVERTURN, ac90degrees, ac270degrees)
        End If
    Else
        layout.PlotRotation = IIf(Plot_U.CB_OVERTURN, ac180degrees, ac0degrees)
    End If
    
    If Plot_U.CB_CenterPlot.Value Then
        layout.CenterPlot = True
    Else
        layout.CenterPlot = False
        newValue(0) = Val(Plot_U.TB_ORIGINX.Text)
        newValue(1) = Val(Plot_U.TB_ORIGINY.Text)
        layout.PlotOrigin = newValue
        'layout.GetPaperMargins MarginLowerLeft, MarginUpperRight
        'layout.GetPaperSize PaperWidth, PaperHeight
        'MsgBox "The PlotOrigin value is set to: " & newValue(0) & " ," & newValue(1)
    End If
    ' выбор единиц измерения чертежа
    layout.PaperUnits = Plot_U.CB_PAPERUNITS.ListIndex
    If (Plot_U.CB_ScaleToFit) Then
        layout.StandardScale = acScaleToFit
    Else
        If (Plot_U.CB_STANDARTSCALE.ListIndex = 0) Then
            layout.UseStandardScale = False
            layout.SetCustomScale Plot_U.TB_NUMERATOR, Plot_U.TB_DENOMINATOR
        Else
            layout.UseStandardScale = True
            layout.StandardScale = Plot_U.CB_STANDARTSCALE.ListIndex
        End If

    End If
        
    'If Plot_U.CB_ROTATEPDFPRINTER.Value Then
    '    layout.ConfigName = IIf(vertic = 1, Plot_U.CB_PRINTNAME.Value, Plot_U.CB_PRINTNAME2.Value)
    '    layout.StyleSheet = IIf(vertic = 1, Plot_U.CB_PRINTSTYLE.Value, Plot_U.CB_PRINTSTYLE2.Value)
    'Else
        layout.ConfigName = IIf(usePrinter = 1, Plot_U.CB_PRINTNAME.Value, Plot_U.CB_PRINTNAME2.Value)
        layout.StyleSheet = IIf(usePrinter = 1, Plot_U.CB_PRINTSTYLE.Value, Plot_U.CB_PRINTSTYLE2.Value)
    'End If
    oPlot.SetLayoutsToPlot LayoutList

    'If Plot_U.CB_ROTATEPDFPRINTER.Value Then
        'oPlot.PlotToDevice IIf(vertic = 1, Plot_U.CB_PRINTNAME.Value, Plot_U.CB_PRINTNAME2.Value)
    'Else
        oPlot.PlotToDevice IIf(usePrinter = 1, Plot_U.CB_PRINTNAME.Value, Plot_U.CB_PRINTNAME2.Value)
    'End If
End Sub

Function getzero(ByVal str)
Do
stry = CStr(str)
If (str >= 1) Then
    If (Mid(stry, Len(stry)) = 0) Then
       str = str / 10
    Else
       getzero = Val(stry)
       Exit Do
    End If
Else
    If (str < 1) Then
        str = str * 10
    Else
        getzero = str
        Exit Do
    End If
End If
Loop
End Function
Sub GetPaperSize(layout As AcadLayout, a As Integer, b As Integer)
On Error GoTo Pnext
        Select Case UCase(a) & b
        Case UCase("A4"):
        Case "11":
            layout.CanonicalMediaName = "A4"
        Case "21":
            layout.CanonicalMediaName = "A3"
        Case "12":
            layout.CanonicalMediaName = "A2"
        Case "22":
            layout.CanonicalMediaName = "A1"
        Case "00":
            layout.CanonicalMediaName = "A0"
        End Select
Exit Sub
Pnext:
    Select Case a & b
        Case "11":
            layout.CanonicalMediaName = WhatIsMyCanonicalMediaName("A4")
        Case "21":
            layout.CanonicalMediaName = WhatIsMyCanonicalMediaName("A3")
        Case "12":
            layout.CanonicalMediaName = WhatIsMyCanonicalMediaName("A2")
        Case "22":
            layout.CanonicalMediaName = WhatIsMyCanonicalMediaName("A1")
        Case "00":
            layout.CanonicalMediaName = WhatIsMyCanonicalMediaName("A0")
        End Select
End Sub
Function WhatIsMyCanonicalMediaName(PaperSizeName As String)
For I = LBound(LocalMediaArray) To UBound(LocalMediaArray)
    If (InStr(1, LocalMediaArray(I), PaperSizeName) > 0) Then
        WhatIsMyCanonicalMediaName = MediaArray(I)
        Exit Function
    End If
Next I
End Function

Public Sub PrintMessage(MessageString As String)

Dim pEchoVal As Integer
    pEchoVal = ThisDrawing.GetVariable("CMDECHO")
    ThisDrawing.SetVariable "CMDECHO", 1
    ThisDrawing.Utility.Prompt MessageString
    ThisDrawing.SetVariable "CMDECHO", pEchoVal
End Sub

Public Sub PrepareSelSet(vAcadDoc As AcadDocument, ss As String, SSet As AcadSelectionSet)
    On Error Resume Next
        Set SSet = vAcadDoc.SelectionSets.Item(ss)
    If Err Then
        Err.Clear
        Set SSet = vAcadDoc.SelectionSets.Add(ss)
    Else
        SSet.Clear
    End If
End Sub

' ищет в модели чертежи, попадающие под заданные пользователем условия
' если opt=true, то печатать автоматически все чертежи
Sub SelectLimits(Optional opt As Byte)
Dim pSS As AcadSelectionSet
Dim pSSTemp As AcadSelectionSet
Dim pText As AcadText

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 countcopy As Byte
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim dxfCode, dxfValue

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
Dim temp As LimitType

' инициализация опций
copycount = Abs(Val(Plot_U.TB_COPYCOUNT.Text))          ' количество копий печати
deltaxy = Val(Plot_U.TB_deltaxy.Text) / 100             ' погрешность по оси
blvertical = Plot_U.CB_VERTICALNUM.Value                ' подряд в столбик
luc = Plot_U.CB_LUC.Value                               ' относительно левого верхнего угла
bSearchText = Plot_U.CB_SEARCHTEXT.Value                ' нужно ли искать текст
If bSearchText And Plot_U.TB_SEARCHTEXT.Enabled = True Then
    SearchText = Trim(Plot_U.TB_SEARCHTEXT.Value)
    If SearchText = "" Then
       MsgBox "Не задан текст для поиска при включенной опции ""Печать только при наличии текста""", vbCritical, "Ошибка"
       Exit Sub
    End If
End If

    If (copycount < 1 Or copycount > 5) Then
        otv = MsgBox("Уверены, что нужно " & copycount & " копий?", vbOKCancel, "Вопрос..")
        If otv = 2 Then Exit Sub
    End If

    I = 0
    J = 0

    pLayer = UCase(Plot_U.TB_LAYERNAME.Text)                             ' слой рамок UCase
    If opt = True Then
        Set pSS = SetSelection("set")
        pSS.Select acSelectionSetAll
    Else
        PrepareSelSet ThisDrawing, "ss", pSS
        PrintMessage vbCrLf & "Выберите объекты:"
        pSS.SelectOnScreen
    End If
    
    If pSS.Count = 0 Then
        PrintMessage " Ничего не выбрано."
        Exit Sub
    Else
        ReDim LimitsArray(pSS.Count)
        ReDim TablesArray(pSS.Count)
    End If

    ' Return the xdata for the line
    If bSearchText Then SearchTextInModel SearchText

    '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"
        If TypeOf pE Is AcadLWPolyline Then
            Set pLWPLine = pE
            If pLayer = UCase(pLWPLine.Layer) Then
                If UBound(pLWPLine.Coordinates) = 7 Or UBound(pLWPLine.Coordinates) = 9 Then
                    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
                    'Проверяем нет ли уже такой рамки в наборе
                    bAllow = True
                    If bSearchText Then
                       bAllow = False
                        For s_t = 1 To UBound(TextArray)
                                If minX < TextArray(s_t).p1(0) And TextArray(s_t).p1(0) < maxX And minY < TextArray(s_t).p1(1) And TextArray(s_t).p1(1) < maxY Then
                                    bAllow = True
                                    Exit For
                                End If
                                If minX < TextArray(s_t).p2(0) And TextArray(s_t).p2(0) < maxX And minY < TextArray(s_t).p2(1) And TextArray(s_t).p2(1) < maxY Then
                                    bAllow = True
                                    Exit For
                                End If
                        Next
                    End If
                    If bAllow Then
                        J = J + 1
                        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
                        'Debug.Print J & " " & UBound(LimitsArray)
                        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
            End If
        'Case Else
        '    pNOther = pNOther + 1
        '    MsgBox TypeName(pE)
        'End Select
        End If
    Next pE
    'ReDim Preserve TablesArray(I)
    ReDim Preserve LimitsArray(J)
    pSS.Delete
    If J = 0 Then
        MsgBox "Нет чертежей для печати", vbCritical, "U_Plot: Ошибка печати"
        Exit Sub
    Else
     If MsgBox("Кол-во рамок: " & J & Chr(13) & "Печатать дальше?", vbOKCancel) = vbCancel Then
        Exit Sub
     End If
    End If
    'todo
    'Таблицы нужно сделать в основной надписи!
'    If I <> J Then
'        If MsgBox("колво рамок и осн. надписей не совпадает: " & J & " рамок, " & I & " осн. надписей" & " Печатать дальше?", vbOKCancel) = vbCancel Then
'            Exit Sub
'        End If
'    End If
    'Сортировка таблиц по номерам
    '
  
' сортировка по Горизонтали либо по вертикали
    For T = 1 To J
        For tt = T + 1 To J
            If (luc) Then
                x1 = LimitsArray(T).p1(0)
                y1 = LimitsArray(T).p2(1)
                x2 = LimitsArray(tt).p1(0)
                y2 = LimitsArray(tt).p2(1)
            Else
                x1 = LimitsArray(T).p1(0)
                y1 = LimitsArray(T).p1(1)
                x2 = LimitsArray(tt).p1(0)
                y2 = LimitsArray(tt).p1(1)
            End If
            blpogr = False
            If (blvertical) Then
                If (Abs(1 - x1 / x2) <= deltaxy) Then blpogr = True
            Else
                If (Abs(1 - y1 / y2) <= deltaxy) Then blpogr = True
            End If
            If (Not blpogr And (((x1 > x2) And blvertical) Xor (Not blvertical And (y1 < y2)))) Then
                temp = LimitsArray(T)
                LimitsArray(T) = LimitsArray(tt)
                LimitsArray(tt) = temp
                P = True
            End If
        Next
    Next
    
    For T = 1 To J
        For tt = T + 1 To J
            If (luc) Then
                x1 = LimitsArray(T).p1(0)
                y1 = LimitsArray(T).p2(1)
                x2 = LimitsArray(tt).p1(0)
                y2 = LimitsArray(tt).p2(1)
            Else
                x1 = LimitsArray(T).p1(0)
                y1 = LimitsArray(T).p1(1)
                x2 = LimitsArray(tt).p1(0)
                y2 = LimitsArray(tt).p1(1)
            End If
            blpogr = True
            If (blvertical) Then
                If (Abs(1 - x1 / x2) <= deltaxy) Then blpogr = False
            Else
                If (Abs(1 - y1 / y2) <= deltaxy) Then blpogr = False
            End If
            If (Not blpogr And ((y1 < y2 And blvertical) Xor (x1 > x2 And Not blvertical))) Then
                temp = LimitsArray(T)
                LimitsArray(T) = LimitsArray(tt)
                LimitsArray(tt) = temp
                P = True
            End If
        Next
    Next

    'BackPlot = ThisDrawing.GetVariable("BACKGROUNDPLOT")
    'ThisDrawing.SetVariable "BACKGROUNDPLOT", 0
    'Печать
    For Copy = 1 To copycount
        For L = 1 To J ' перебираем рамки
            With LimitsArray(L)
                i_odd = L
                PlotFile .p1, .p2
            End With
        Next
    Next
    'ThisDrawing.SetVariable "BACKGROUNDPLOT", BackPlot
    'CalculateSpecification
End Sub

'----------------------------------------------------------------------------------------------
Sub search_layer_count(Form_text As String)
    Dim ftype(0) As Integer
    Dim fdata(0) As Variant
    Dim dxfCode, dxfValue
    Dim oSset As AcadSelectionSet
    Dim minExt, maxExt
    Set oSset = SetSelection("NewSset")
    ftype(0) = 0: fdata(0) = "LWPOLYLINE" '<--"*LINE,..."
    dxfCode = ftype: dxfValue = fdata
    oSset.Select acSelectionSetAll, , , dxfCode, dxfValue
    If (Plot_U.CB_SEARCHTEXT) Then SearchTextInModel Plot_U.TB_SEARCHTEXT.Text
    n = 0
    For Each pE In oSset
        If (Trim(LCase(pE.Layer)) = Trim(LCase(Form_text))) Then
            If TypeOf pE Is AcadLWPolyline Then
                If (Plot_U.CB_SEARCHTEXT) Then
                    pE.GetBoundingBox minExt, maxExt
                    For s_i = 1 To UBound(TextArray)
                        If (minExt(0) < TextArray(s_i).p1(0) And TextArray(s_i).p1(0) < maxExt(0) And minExt(1) < TextArray(s_i).p1(1) And TextArray(s_i).p1(1) < maxExt(1)) Or (minExt(0) < TextArray(s_i).p2(0) And TextArray(s_i).p2(0) < maxExt(0) And minExt(1) < TextArray(s_i).p2(1) And TextArray(s_i).p2(1) < maxExt(1)) Then
                            n = n + 1
                            Exit For
                        End If
                    Next
                Else
                    n = n + 1
                End If
            End If
        End If
    Next
    'For I = 0 To oSset.Count - 1
    '    If (Trim(LCase(oSset.Item(I).Layer)) = Trim(LCase(Form_text))) Then n = n + 1
    'Next
    Plot_U.layer_count.Caption = n & " рамок"
    ThisDrawing.SelectionSets("NewSset").Delete
End Sub

Function SetSelection(s_text As String) As AcadSelectionSet
On Error GoTo ErrLine
Set SetSelection = ThisDrawing.SelectionSets.Add(s_text)
Exit Function
ErrLine:
Set SetSelection = ThisDrawing.SelectionSets(s_text)
ThisDrawing.SelectionSets(s_text).Clear
End Function

Sub SearchTextInModel(f_text)
    Dim minExt As Variant
    Dim maxExt As Variant
    Dim ftype(0) As Integer
    Dim fdata(0) As Variant
    Dim dxfCode, dxfValue
    text_count = 0
    Set pSSTemp = SetSelection("settemp")
    ftype(0) = 0: fdata(0) = "TEXT" '<--"*LINE,..."
    dxfCode = ftype: dxfValue = fdata
    pSSTemp.Select acSelectionSetAll, , , dxfCode, dxfValue
    ReDim TextArray(0 To pSSTemp.Count)
    For Each pE In pSSTemp
    Set pText = pE
    If UCase(pText.TextString) = UCase(f_text) Then
        pText.GetBoundingBox minExt, maxExt
        text_count = text_count + 1
        TextArray(text_count).p1(0) = minExt(0): TextArray(text_count).p1(1) = minExt(1)
        TextArray(text_count).p2(0) = maxExt(0): TextArray(text_count).p2(1) = maxExt(1)
    End If
    Next
    ReDim Preserve TextArray(text_count)
    ThisDrawing.SelectionSets("settemp").Delete
End Sub
'http://forum.dwg.ru/showthread.php?t=64072
Private Sub change_Target()
    ' Get an active model space viewport
    Dim viewportObj As AcadViewport
    Set viewportObj = ThisDrawing.ActiveViewport
    
    ' Find the current target
    Dim currTarget As Variant

    currTarget = viewportObj.Target
    
    If viewportObj.Target(0) <> 0# Or viewportObj.Target(1) <> 0# Or viewportObj.Target(2) <> 0# Then
        
         'Change the target
        Dim newTarget(0 To 2) As Double
        newTarget(0) = 0#: newTarget(1) = 0#: newTarget(2) = 0
        viewportObj.Target = newTarget
        ThisDrawing.ActiveViewport = viewportObj
        ThisDrawing.Regen acAllViewports
        
        ZoomAll
    End If
   
End Sub

' поиск элемента в массиве
Function CheckInArr(f_arr, f_el)
    CheckInArr = False
    If UBound(f_arr) >= 0 Then
        For f_i = LBound(f_arr) To UBound(f_arr)
            If UCase(f_el) = UCase(f_arr(f_i, 0)) Then
                CheckInArr = True
                Exit Function
            End If
        Next
    End If
End Function

Сообщение от maratovich ы ищите готовое решение ? Так оно уже давно есть, под все Ваши потребности.

Где?

----- добавлено через 33 сек. -----
Мне надо либо дать литературу и помочь или сделать самим.

[maratovich]

Сообщение от tujn08 Где?

Вот тема где почитать
Вот готовое решение

[swell{d}]

tujn08, выложите "модуль", а то код без разметки читать невозможно

[tujn08]

Ого - вот это да. Почему я раньше не спрашивал здесь?! На днях мы печатали 10 100 листов

[tujn08]

А notepad++ не установлен у Вас?