[andruto]

Доброго времени суток.
Столкнулся со следующей проблемой...
Работаю в AutoCAD 2009, использую такие макросы как Plot.dvb(печать из модели) и Number(автонумератор).
После некоторых внесенных мной изменений в код макроса печати его пришлось снести. Снес как из автозагрузки, так и из диспетчера vba.
Повторная загрузка макроса(оригинала) приводит к тому, что макрос отображается в диспетчере vba, но не появляется в "макросах"=> запустить макрос не представляется возможным.
Запустить получается только из Редактора VB нажатием run. При этом макрос "автонумератор" можно сносить и ставить обратно без проблем.
Проверил на AutoCAD 2014 та же история....

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

Замечательно... А код где?

[andruto]

Код:

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

Type LimitType
    p1(0 To 2) As Double
    p2(0 To 2) As Double
    Plotted As Boolean
End Type


Dim LimitsArray() As LimitType ' Массив Рамок
Dim TablesArray() As AcadTable 'IAcadTable2 ' массив основных надписей


Sub PlotFile(p1 As Variant, p2 As Variant)

    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
    ReDim Preserve AddedLayouts(1 To 1)
    'ReDim point1(0 To 1)
    'ReDim point2(0 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) = Trim(UserForm1.TextBox3.Text) '"Модель"
    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
    'Layout.PlotType = acWindow
    Layout.CenterPlot = True
    Layout.SetWindowToPlot point1, point2
    If point2(0) - point1(0) > point2(1) - point1(1) Then
        Layout.PlotRotation = ac270degrees 'ac90degrees
        
    Else
        Layout.PlotRotation = ac0degrees
    End If
    
    oPlot.SetLayoutsToPlot LayoutList
    'PlotConfig.CanonicalMediaName=
    
    'oPlot.PlotToDevice "Adobe PDF"
    oPlot.PlotToDevice UserForm1.ComboBox1.Text
End Sub


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

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

Собственно макрос...!Plot.dvb

[Mercenary]

Переделывал этот макрос с AutoCAD2004 под AutoCAD2007(там менялись обозначения полилиний, для этого связывался с создателем). Сейчас переход на AutoCAD2014 - макрос запускается, но не печатает(( Может опять что изменили?