[basboy]

Мне нужно в VBA просканировать чертёжь и выделить группы окружностейб затем у определённой нруппы изменить свойства.

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

[{Smirnoff}]

Как то так:

Код:

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

Public Sub CirclesSelect(AcadDoc As AcadDocument)
Dim SelSetColl As AcadSelectionSets
Dim CirSet As AcadSelectionSet
Dim Item As AcadEntity
Dim FilterType(0 To 0) As Integer
Dim FilterData(0 To 0) As Variant

FilterType(0) = 0

FilterData(0) = "CIRCLE"

Set SelSetColl = AcadDoc.SelectionSets
Set CirSet = SelSetColl.Add("MySet")
CirtSet.Select acSelectionSetAll, , , FilterType, FilterData

For Each Item In CirSet

' Ваши действия с каждой окружностью
    
Next Item

CirSet.Delete
Set CirSet = Nothing
Set SelSetColl = Nothing

End Sub

[basboy]

Спасибо, попробуем...

[basboy]

Fantomas, чё-то не покатил код. Мот я не правильно чё делаю.
Я вообще в VBA не проф.
Я так понимаю, что функцию нужно вызывать типо так: CirclesSelect ThisDrawing

Тогда компилятор ругается на строчку Set CirSet = SelSetColl.Add("MySet")

Меса такая:
"The named selection set exists"

При пошаговом компилировании видно, что после выполнения строчки Set SelSetColl = AcadDoc.SelectionSets переменная SelSetColl ничего не содержит.

[{Smirnoff}]

К вечеру запущу у себя, сейчас времени нет. Я это по быстрому в окне форума из другой процедуры переделал. Кстати посмотри, может у тебя там не то, потому что через несколько минут, я посмотрел нашел ошибки и исправил, а ты к тому времени уже мог скопировать. То на что он ругается это неуничтоженный по какой то причине набор "MySet" (Set CirSet = Nothing) , вообще название надо поменять, слишком тривиально и может повторятся вдругих прогах... Если действительно у тебя не иправленный листинг запускай в новом файле (в старом опять на дублирующиеся название набора ругнется), обработчик ошибок уничтожающий объекты в любом случае я допишу. В VBA тоже пока не профи...

[{Smirnoff}]

Да была дурацкая ошибка, нельзя править в окне форума без проверки :evil: Вместо CirSet в одном месте было CirtSet. Теперь работает, красит окружности в зелёный цвет.

Код:

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

Public Sub CirclesSelect(AcadDoc As AcadDocument)
Dim SelSetColl As AcadSelectionSets
Dim CirSet As AcadSelectionSet
Dim Item As AcadEntity
Dim FilterType(0 To 0) As Integer
Dim FilterData(0 To 0) As Variant

FilterType(0) = 0

FilterData(0) = "Circle"

Set SelSetColl = AcadDoc.SelectionSets
Set CirSet = SelSetColl.Add("763Set28")
CirSet.Select acSelectionSetAll, , , FilterType, FilterData

For Each Item In CirSet

Item.color = acGreen
   
Next Item

CirSet.Delete
Set CirSet = Nothing
Set SelSetColl = Nothing

End Sub

Sub Test()
CirclesSelect ThisDrawing
End Sub

Извиняй, не досмотрел...

[basboy]

ОК.

Спасибо, всё заработало.