[gizmo_zx]

Добрый день.
Подскажите как вставить все блоки содержащиеся в текущем файле в модель.
Вставить горизонтально по линии с определенным шагом (например 1000).
Атрибуты заполнить значениями "по умолчанию" (не очень важно).
Цель отобразить все блоки, какие есть в файле.
Можно Lisp, но лучше на VBA.

[Лиспер]

А простой DesignCenter не устраивает?

[gizmo_zx]

Не совсем. это надо каждый щелкнуть и вставить. А блоков несколько сотен.

[Vildar]

Код:

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

Public Sub InsBlocks()
   Dim blItem As AcadBlock
   Dim pt(0 To 2) As Double
   Dim iCol As Integer
   
   For Each blItem In ThisDrawing.Blocks
      If Not blItem.IsLayout Then
         ThisDrawing.ModelSpace.InsertBlock pt, blItem.Name, 1, 1, 1, 0
         pt(0) = pt(0) + 1000
         iCol = iCol + 1
         If iCol = 10 Then
            pt(1) = pt(1) - 1000
            pt(0) = 0
            iCol = 0
         End If
      End If
   Next
End Sub

[Boxa]

стёр

[gizmo_zx]

А можно указать папку с файлами и из всех файлов вытащить в один и выстроить также в линию. Буду просто счастлив!!!

[Vildar]

Это шутка чтоли?

[Лиспер]

gizmo_zx, вот скажи - зачем тебе все это? Конечная цель какова?

[gizmo_zx]

Есть около 100 файлов в них в каждом около 100 блоков.
Нужно визуально найти примерно 10 блоков, т.к. есть только фотка в брошуре, нужны габаритные размеры. Вот их то из блоков хочу достать.

[Лиспер]

Я бы работал через палитры инструментов. Намного более удобное средство, мне кажется.
Offtop: Как полное извращение: все объединить в один файл и создать на его основе палитру инструментов.

[gizmo_zx]

мне это разово (надеюсь). проблемма открыть сто файлов и просмотреть каждый блок.
как объединить все файлы в один?

[Лиспер]

Через _.insert, например.

[gizmo_zx]

через _.insert можно выбрать 1 файл. А разом можно. Offtop: Да я такой

[Лиспер]

Через _.xref вставить сколько надо, потом разбить связь (bind).

[Vildar]

Код:

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

Public Sub InsBlocks()
   Dim blItem As AcadBlock
   Dim doc As Object
   Dim text As AcadText
   Dim ents(0) As Object
   Dim pt(0 To 2) As Double
   Dim iCol As Integer
   Dim sDir As String
   Dim sValue As String
   Dim sFile As String
   Dim sDbxVer As String
   
   On Error GoTo HasError
    
   sDbxVer = "ObjectDBX.AxDbDocument." & CInt(Val(Application.Version))
   Set doc = Application.GetInterfaceObject(sDbxVer)
   
   ' Путь к папке с блоками
   sDir = "d:/Blocks/"
   
   ' Перебираем файлы в папке, без учета подкаталогов
   sValue = Dir(sDir + "/*.dwg")
   Do While sValue <> ""
      sFile = sDir + sValue
      doc.Open sFile
      
      pt(0) = 0
      pt(1) = pt(1) - 1000
      Set text = ThisDrawing.ModelSpace.AddText(sFile, pt, 100)
      pt(1) = pt(1) - 1000
      
      For Each blItem In doc.Blocks
         If Not blItem.IsLayout Then
            Set ents(0) = blItem
            doc.CopyObjects ents, ThisDrawing.Blocks
            ThisDrawing.ModelSpace.InsertBlock pt, blItem.Name, 1, 1, 1, 0
            pt(0) = pt(0) + 1000
            iCol = iCol + 1
            If iCol = 10 Then
               pt(1) = pt(1) - 1000
               pt(0) = 0
               iCol = 0
            End If
         End If
      Next
      
      sValue = Dir()
   Loop
End
   
HasError:
   MsgBox Err.Description
   
End Sub

Измени путь к папке с блоками.
Вложенные папки не обрабатываются.
Блоки с одинаковыми именами в разных файлах не обрабатываются. Определяется только блок из первого файла. По идее, нужно проверять нет ли уже блока с таким именем и добавлять рандомное число к имени блока, или еще как. Может сам доделаешь.
Изменил код. Сделал позднее связывание с DBX.

[KAI]

Сообщение от gizmo_zx проблема открыть сто файлов и просмотреть каждый блок.

Если не для 100 файлов, то может пригодиться программа DNO (Drawing_Named_Objects, комплекс KAI-2001, системные программы).
Значения атрибутов заменяются на TAGи.
Для блоков кроме имени выводится также количество объектов в блоке, количество атрибутов и имена слоев, на которых определены объекты.