суббота, 9 мая 2015 г.

Как рисовать выноски и заполнять атрибуты блоков из Excel в AutoCAD при помощи VBA

Рисовать примитивы в AutoCAD из Excel проще простого.
Для этого нужны примитивные знания VBA - чтобы можно было поправить ниже приведенный код.
Я "не настоящий сварщик" - сделал как умею, поэтому возможно, что и кривовато получилось - но, главное, что работает.
Для подключения нужно войти в режим разработчика: Alt+F8 Либо можно открыть вкладку "разработчик" из настроек ленты.




В окне разработчика VBA входим в верхнее меню: Tools/References
В этом окне нужно поставить галочку на вашей версии AutoCAD

В моем случае это AutoCAD 2014 Type Library
Далее нужно в левом окне создать в вашей книге модуль, как на скриншоте (Module)





И в модуль вставляем нижеприведенный код


Sub DrawMLeader() 'рисуем выноску

    Dim acadApp As AcadApplication
    Dim acadDoc As AcadDocument
    Application.DisplayAlerts = False
    
    
    
    'Check if AutoCAD is open.
    On Error Resume Next
    Set acadApp = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    
    'If AutoCAD is not opened create a new instance and make it visible.
    If acadApp Is Nothing Then
        Set acadApp = New AcadApplication
        acadApp.Visible = True
    End If
    
    'Check if there is an active drawing.
    On Error Resume Next
    Set acadDoc = acadApp.ActiveDocument
    On Error GoTo 0
    
    'No active drawing found. Create a new one.
    If acadDoc Is Nothing Then
        Set acadDoc = acadApp.Documents.Add
        acadApp.Visible = True
    End If
   
   Dim AML As AcadMLeader
Dim xx As Long
Dim ss As String

ActiveCell.Cells.Activate
ss = ActiveCell.Cells.Value

Dim points(0 To 5) As Double

Dim startPnt As Variant, endPnt As Variant
  Dim prompt1 As String, prompt2 As String
  prompt1 = vbCrLf & "Начало выноски: "
  prompt2 = vbCrLf & "Конец выноски: "
  startPnt = acadDoc.Utility.GetPoint(, prompt1)
  endPnt = acadDoc.Utility.GetPoint(startPnt, prompt2)


'заполняем массив точек для MLeader
points(0) = startPnt(0)
    points(1) = startPnt(1)
    points(2) = 0
  
    points(3) = endPnt(0)
    points(4) = endPnt(1)
    points(5) = 0
    

Set AML = acadDoc.ModelSpace.AddMLeader(points, xx)
AML.TextString = ss
AML.ArrowheadType = acArrowNone
'если нужна другая высота текста - эту позицию меняем тут, или в настройках Mleader в AutoCAD
AML.TextHeight = 250
AML.TextLeftAttachmentType = acAttachmentBottomOfTopLine
AML.TextRightAttachmentType = acAttachmentBottomOfTopLine
AML.LandingGap = 2

Dim entHandle As String
entHandle = AML.Handle
ActiveCell.Offset(0, 1).Value = entHandle
   
acadDoc.Application.Update
'меняю цвет ячейки, откуда получил текст, чтобы было понятно, что текст обработан.
ActiveCell.Cells.Interior.ColorIndex = 6 End Sub


Аналогичным способом можно создавать блоки с атрибутами, в которые можно вставлять текст из ячеек.
Нужно внести в верхний код изменения вроде:   
Dim blockObj As Object 'обозвали блок
'вставили блок, маркер воздухообмена - это имя вашего блока, который должен быть уже в чертеже:
Set blockObj = acadDoc.ModelSpace.InsertBlock(startPnt, "Маркер воздухообмена", 1, 1, 1, 0, [])

'заполняем атрибуты, можно сделать по-умнее, но мне лень было разбираться, я сделал по рабоче-крестьянски (работает и ладно)
Dim varAttributes As Variant varAttributes = blockObj.GetAttributes varAttributes(0).TextString = ss1 'приток varAttributes(1).TextString = ss2 'вытяжка varAttributes(2).TextString = ss 'описание помещения
    
Dim entHandle As String 'тут я получаю хэндл нашего блока и пишу его в соседнюю ячейку, для того, чтобы можно было при изменении текста в Excel обновить просто блок в AutoCAD.

entHandle = blockObj.Handle
ActiveCell.Offset(0, 3).Value = entHandle



Код обновления текста по хэндлу - написан ниже: 'получаем хэндл из ячейки, в которую мы записали кодом выше entHandle = ActiveCell.Offset(0, 3).Value
'получили наш блок по хэндлу
Set blockObj = acadDoc.HandleToObject(entHandle)
И дальше так же как и в коде выше - заполняем атрибуты в блоке< Небольшое видео, для иллюстрации того, что происходит на экране


UPD
Эта статья опубликована на хабре

UPD2
Для работающих на одномониторных станциях не удобно, что фокус не передается в окно автокада автоматически, для этого нужно внести следующие изменения в код:
В начале, где мы только подключились к AutoCAD


On Error Resume Next
    Set acadApp = GetObject(, "AutoCAD.Application")
    
    acadApp.WindowState = 3
    AppActivate acadApp.Caption 'фокус передаем в AutoCAD

После того, как мы обработали в AutoCAD нужно переключиться в Excel - делаем это следующим образом:


acadDoc.Application.Update

acadApp.WindowState = 2
DoEvents
AppActivate Application.Caption 'передаем фокус окну Excel
Application.Windows.Item(1).Activate


ActiveCell.Cells.Interior.ColorIndex = 6


UPD3
Добавил файлы Excel и файл с блоком расхода воздуха AutoCAD для примера
Блок воздухообмена AutoCAD
Файл Excel

14 комментариев:

  1. Крутотенюшка. Не знал, что так можно.
    А можно интересно обновлять уже существующие блоки/выноски. Например, подписана на плане завеса У1. А из Excel ей обновить характеристику при изменении.

    ОтветитьУдалить
  2. При изменении значений в ячейках Excel не получается обновить данные в автокаде, как выполнить обновление?

    ОтветитьУдалить
    Ответы
    1. А как вы делаете обновление?

      Удалить
    2. В автокаде пытался регенерировать всё, потом увидел что можно обновить по хэндлу но как это выполнить не знаю.

      Удалить
    3. Бесполезно регенерить в автокаде, т.к. при вставке данные просто копируются. Для связки надо рядом с ячейкой вставить хэндл получившегося объекта из Автокада.
      Вот в этой строке вы вставляете в соседнюю ячейку хэндл полученного объекта:
      Dim entHandle As String
      entHandle = AML.Handle
      ActiveCell.Offset(0, 1).Value = entHandle
      ----
      Offset(0, 3) - это смещение на три ячейки вправо от активной.
      ----
      Для обновления в автокаде нужен следующий код:
      entHandle = ActiveCell.Offset(0, 3).Value
      Set blockObj = acadDoc.HandleToObject(entHandle)
      ---
      Это все описано в этой же статье.

      Удалить
    4. Прошу прощения везде должно быть одинаково:
      ActiveCell.Offset(0, 3).Value = entHandle

      Удалить
    5. Владимир, чтобы было проще разобраться - я выложил в конце статьи свои файлы рабочие. Может так будет проще Вам разобраться как обновлять блоки на чертеже?

      Удалить
  3. Я эти файлы только сегодня заметил, скачал, сижу разбираюсь. Мануал по работе с макросами не запускается.

    ОтветитьУдалить
  4. Огромное спасибо за помощь, разобрался, всё получилось, блок обновляется.

    ОтветитьУдалить
    Ответы
    1. При желании можно добавить поиск этого блока на чертеже и обновление сразу всех скопом.

      Удалить
    2. Ну обновление в моем файле и так всем скопом организовано. Какие строки выделил - такие и обновились. А поиск - да. Мощная идея. Виктор, выложи свой кусок кода по поиску.

      Удалить
    3. Dim blockObj As Object
      Dim vMin As Variant
      Dim vMax As Variant
      Dim entHandle As String

      AppActivate ("AutoCAD")
      entHandle = ActiveCell.Offset(0, 1).Value
      Set blockObj = acadDoc.HandleToObject(entHandle)
      blockObj.GetBoundingBox vMin, vMax
      acadDoc.Application.ZoomWindow vMin, vMax
      -----
      Насчет AppActivate ("AutoCAD"), наверно, не самое удачное решение, потому как это слово может быть и в других заголовках окна. Но можно написать "Autodesk AutoCAD" или "AutoCAD 2014" в зависимости от того, какая у вас сейчас версия.

      Удалить
  5. выдает сообщение can't find project or library

    ОтветитьУдалить
  6. Здравствуйте! А можно повторные ссылки на файлы в upd 3 кинуть? Эти не открываются.

    ОтветитьУдалить