• На форуме с 5 февраля 2019г.
  • Сообщений: 5
  • Спасибо: 0

Тема: Как циклом перебрать выделенные блоки в AutoCad?

Всем привет.

На форуме не нашел такой темы.

Нашел код по перебору в цикле всех блоков на чертеже:

  Dim I As Integer
  Dim msg As String
  msg = ""

  For I = 0 To ThisDrawing.Blocks.Count - 1
    msg = msg + ThisDrawing.Blocks.Item(I).Name + vbCrLf
  Next

  MsgBox msg

Попробывал перебрать так:

   Dim objSelSet As AcadSelectionSet
   Dim objSelCol As AcadSelectionSets

   Set objSelCol = ThisDrawing.SelectionSets

   For Each objSelSet In objSelCol
       MsgBox ThisDrawing.SelectionSets.Item(I).Name
   Next

Ничего не выдает.

Как решить данный вопрос?
Переберать выделенные блоки нужно, что бы просматривать их атрибуты.

Заранее спасибо!

  • На форуме с 5 февраля 2019г.
  • Сообщений: 5
  • Спасибо: 0

Re: Как циклом перебрать выделенные блоки в AutoCad?

Код VBA/ActiveX

1:  Sub SelectObjectsOnscreen()
   2:   
   3:      ' Создание нового набора
   4:      Dim sset As AcadSelectionSet
   5:      Set sset = ThisDrawing.SelectionSets.Add("SS1") 
   6:   
   7:      ' Запрос пользователю выбрать объекты
   8:      '  и добаволение их в набор
   9:      sset.SelectOnScreen
  10:      Dim acEnt As AcadEntity 
  11:   
  12:      ' Перебор выбранных объектов и изменение цвета на зеленый
  13:      For Each acEnt In sset
  14:          ' Использование свойства Цвета для установки цвета объекту
  15:          acEnt.color = acGreen
  16:      Next acEnt 
  17:   
  18:      ' Удаление набора
  19:      sset.Delete
  20:  End Sub

  • На форуме с 5 февраля 2019г.
  • Сообщений: 5
  • Спасибо: 0

Re: Как циклом перебрать выделенные блоки в AutoCad?

Ура! Все работает.
Код переберает все выделенные блоки и все атрибуты в самом блоке.

Dim acEnt As AcadEntity
 
 Dim varAtts As Variant
 Dim intCnt As Integer
 Dim varHt As Variant
 Dim varPnt As Variant

 ' Создание нового набора
 Dim sset As AcadSelectionSet
 Set sset = ThisDrawing.SelectionSets.Add("SS2")

 ' Запрос пользователю выбрать объекты и добаволение их в набор
 sset.SelectOnScreen


 ' Перебор выбранных объектов
 For Each acEnt In sset

   MsgBox acEnt.ObjectName
   
   If TypeOf acEnt Is AcadBlockReference Then
      
      If acEnt.HasAttributes Then
      
         varAtts = acEnt.GetAttributes
      
         For intCnt = LBound(varAtts) To UBound(varAtts)
             MsgBox varAtts(intCnt).TagString + " - " + varAtts(intCnt).TextString, varPnt, varHt
         Next intCnt
         
      End If
      
    End If
    
 Next acEnt

 ' Удаление набора
 sset.Delete
End Sub