[Vadim_EC]

Добрый день. При выполнении события зависает. Возможно, происходит бесконечно вызов самой себя, но где происходит эта рекурсия ума не приложу. Помогите пожалуйста решить проблему.

Код основного модуля:

Код:

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

 Option Explicit
Public oDicIDObjToDelete As New Scripting.Dictionary ' словарь контейнер
Public oDicObjOfEvents As New Scripting.Dictionary 'словарь с событиями
Public LayerOfSupport$
Public arrFilterData()
Public arrFilterType(2) As Integer
Public dDist#
Public bCheckMain As Boolean

'Dim X As New EventClass
Sub main()
    bCheckMain = False
    LayerOfSupport = "0"
    dDist = 0.5
    arrFilterType(0) = 0
    arrFilterType(1) = 8
    arrFilterType(2) = 67
    arrFilterData = Array("LWPOLYLINE", "__Слой_Не_Печатается_1", 0)
    oDicIDObjToDelete.RemoveAll
    oDicObjOfEvents.RemoveAll
    Call InitializeEvents
End Sub
Sub InitializeEvents()
    Dim oSelSet As AcadSelectionSet
    Dim oPLine As AcadLWPolyline
    'Dim dDist As Double
    Dim arrPLinesID
    

    Set oSelSet = pf_SelectionSet_CreateInThisDrawing(False, "Temp", 1)
    Set oSelSet = pf_SelectionSet_MultiSelect(oSelSet, True, arrFilterType, arrFilterData)
    ReDim arrPLinesID(1)
    For Each oPLine In oSelSet

        Call f_ClassObjectNew(oPLine)
        'arrPLinesID = pf_LWPolyLine2Offset(oPLine, dDist, LayerOfSupport) временно убрал функцию но все равно зависает
        'Call oDicIDObjToDelete.Add(CStr(oPLine.ObjectID), arrPLinesID) временно убрал функцию но все равно зависает
    Next
    oSelSet.Delete
End Sub


Sub f_ClassObjectNew(oPLine As AcadLWPolyline)
    Dim oEvent As New EventsClass
    Dim arrID
    Set oEvent.Object = oPLine
    Call oDicObjOfEvents.Add(CStr(oPLine.ObjectID), oEvent)
End Sub

Код класса события:


Option Explicit
Public WithEvents Object As AcadLWPolyline

Код:

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

 Private Sub Object_Modified(ByVal pObject As IAcadObject) ' IAcadObject)
    Dim oPLineToDelete As AcadLWPolyline
    Dim arrPLinesID, arrPLinesIDTemp
    Dim arrIDToDelete
    Dim sLayerName$
    Dim sID$
    Dim oPLineTemp1 As AcadLWPolyline, oPLineTemp2 As AcadLWPolyline
    Dim retObj As Variant
    Dim arrIdNewLines(1)
    
    If bCheckMain And Not pObject.Layer = "__Слой_Не_Печатается_1" Then GoTo good
    bCheckMain = True
    On Error Resume Next
    Set oPLineTemp1 = pObject.Copy 'копирую объект события
    sID = CStr(pObject.ObjectID) ' ID для получения объектов к удалению
    arrIDToDelete = oDicIDObjToDelete(sID) ' получаю id объектов к удалению
    Set oPLineToDelete = ThisDrawing.ObjectIdToObject(arrIDToDelete(0))
    oPLineToDelete.Delete
    Set oPLineToDelete = ThisDrawing.ObjectIdToObject(arrIDToDelete(1))
    oPLineToDelete.Delete
    oPLineTemp1.Layer = LayerOfSupport


    retObj = oPLineTemp1.Offset(dDist)
    Set oPLineTemp2 = retObj(0)
    arrIdNewLines(0) = oPLineTemp2.ObjectID
    retObj = oPLineTemp1.Offset(-dDist)

    Set oPLineTemp2 = retObj(0)
    arrIdNewLines(1) = oPLineTemp2.ObjectID
    oDicIDObjToDelete(sID) = arrIdNewLines
    oPLineTemp1.Delete
    'Debug.Print pObject.ObjectID
    
        
    
    On Error GoTo 0

good:

bCheckMain = False

End Sub

[Сергей812]

в среде разработки VBA есть пошаговая отладка - по F8 проходите по коду построчно и смотрите - не "прыгнет" ли снова исполнение на начало метода.

[Vadim_EC]

Побывал, но весь код проходит нормально, потом пишет в Акаде что "Невозможно выполнить макрос, т.к. AutocCAD занят." Но если просто запустить F5 тогда зависает.

----- добавлено через ~16 мин. -----
Сделал более простую процедуру для теста все операции с pObject исключил и да работает. Может кто знает есть ли возможность временно отключить исполнения события?

Код:

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

Private Sub Object_Modified(ByVal pObject As IAcadObject) ' IAcadObject)
    Dim oPLineToDelete As AcadLWPolyline
    Dim arrPLinesID, arrPLinesIDTemp
    Dim arrIDToDelete
    Dim sLayerName$
    Dim sID$
    Dim oPLineTemp1 As AcadLWPolyline, oPLineTemp2 As AcadLWPolyline
    Dim retObj As Variant
    Dim arrIdNewLines(1)
    
    If bCheckMain And Not pObject.Layer = "__Слой_Не_Печатается_1" Then GoTo good
    bCheckMain = True
    On Error Resume Next
    MsgBox "Done"
    
    On Error GoTo 0

good:

bCheckMain = False
End Sub

[Сергей812]

а это вообще плохая идея - внутри события модификации БД модифицировать БД) Собираете в обработчике информацию об объектах, что надо изменить и где-то сохраняете в коллекции. А потом в событие idle (простоя) обрабатываете коллекцию. При этом можно тот же флаг использовать, чтобы снова не сохраняло в коллекцию. Либо просто на время отписать обработчик события.

[Vadim_EC]

Сообщение от Сергей812 а это вообще плохая идея - внутри события модификации БД модифицировать БД)

согласен так себе решение, был глуп и безумен.

Идею вашу понял. Осталось понять как это реализовать.

ПС Может кто подскажет где найти рабочую прогу для нахождения режима простоя idle для VBA?

[Сергей812]

Сообщение от Vadim_EC где найти рабочую прогу для нахождения режима простоя idle для VBA?

это такой же обработчик события уровня приложения (application), только не факт - что он "вытащен" в VBA. В хэлпе официальном его не вижу, во всяком случае.

[Vadim_EC]

Нашел решение: вместо копирования объекта с событием беру его координаты и создаю новую линию. После этого создаю линии offset от данной линии. И все оки-доки.
Вообщем полилиния "превратилась" почти в мультилинию))

Код:

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

Private Sub Object_Modified(ByVal pObject As IAcadObject) ' IAcadObject)
    Dim oPLineToDelete As AcadLWPolyline
    Dim arrPLinesID, arrPLinesIDTemp
    Dim arrIDToDelete
    Dim sLayerName$
    Dim sID$
    Dim oPLineTemp1 As AcadLWPolyline, oPLineTemp2 As AcadLWPolyline
    Dim retObj As Variant
    Dim arrIdNewLines(1), arrCoordinates

    If bCheckMain And Not pObject.Layer = "__Слой_Не_Печатается_1" Then GoTo good
    bCheckMain = True
    On Error Resume Next
    'Set oPLineTemp1 = pObject.Copy 'копирую объект события
    sID = CStr(pObject.ObjectID) ' ID для получения объектов к удалению
    arrCoordinates = pObject.Coordinates ' получаю координаты объекта что бы создать новую поли линию не привязанный к событию
    arrIDToDelete = oDicIDObjToDelete(sID) ' получаю id объектов к удалению
    Set oPLineTemp1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(arrCoordinates)
    Set oPLineToDelete = ThisDrawing.ObjectIdToObject(arrIDToDelete(0))
    oPLineToDelete.Delete
    Set oPLineToDelete = ThisDrawing.ObjectIdToObject(arrIDToDelete(1))
    oPLineToDelete.Delete
    oPLineTemp1.Layer = LayerOfSupport


    retObj = oPLineTemp1.Offset(dDist)
    Set oPLineTemp2 = retObj(0)
    arrIdNewLines(0) = oPLineTemp2.ObjectID
    retObj = oPLineTemp1.Offset(-dDist)

    Set oPLineTemp2 = retObj(0)
    arrIdNewLines(1) = oPLineTemp2.ObjectID
    oDicIDObjToDelete(sID) = arrIdNewLines
    oPLineTemp1.Delete
    'Debug.Print pObject.ObjectID



    On Error GoTo 0

good:

bCheckMain = False
'Stop
End Sub