Набор функций для работы с блоками и атрибутами средствами AutoLISP WWW.CAD.DP.UA

Набор функций для работы с блоками и атрибутами средствами AutoLISP

Удаление всех блоков с определенным именем
Проверить блок с определенным именем на существование
Переименовать блок
Список имен всех блоков
Список имен всех внешних ссылок
Возвращает список с ссылками на определенные блоки
Возвращает список, содержащий каждую ссылку на данный блок
Возвращает список, содержащий имена примитивов определений блоков, которые ссылаются на данный блок
Удаляет указанные примитивы из определения блока
Добавляет указанный элемент к данному определению блока
Конвертирует набор выбора в массив ActiveX
Находит значение указанного блока и атрибута
Находит блок с указанным именем, атрибутом или значением</li>
Создает список всех блоков с их именами и атрибутами по порядку y-координаты, снизу вверх.
Изменяет значение атрибута указанного блока на указанное значение атрибута
Изменяет высоту атрибута
Список точек вставки и ссылок на блоки в активном листе, отсортированные по y-значению
Изменяет точку вставки тэга
Изменяет атрибуты на всех ссылках блоков, соответствующих указанному имени
Изменяет ширину атрибута

Удаление всех блоков с определенным именем

;;; (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))

;;; Удаляет все блоки с именем "revtext2"
;;; (ax:EraseBlock doc "revtext2")
(defun ax:EraseBlock (doc bn / layout i)
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (vla-Delete i) 
      )
    )
  )
)

Проверить блок с определенным именем на существование

;;; Проверка, существует ли блок с именем "revtext2"
;;; (ax:ExistBlock doc "revtext2")
(defun ax:ExistBlock (doc bn / layout i exist)
  (setq exist nil)
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (setq exist T)
      )
    )
  )
  exist
)

Переименовать блок

;;; Переименовать блок "revtext" в "revtext1"
;;; (ax:RenameBlock doc "revtext" "revtext1")
(defun ax:RenameBlock (doc bn nn / layout i)
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (vla-put-name i nn)
      )
    )
  )
)

Список имен всех блоков

;;; список всех имен блоков
;;; пример возращаемого значения: ("*D5" "A$C263E5435" "b2" "b1")
(defun ax:blocks (/ b bn tl)
  (vlax-for b (vla-get-blocks
                (vla-get-ActiveDocument (vlax-get-acad-object))
              )
    (if (= (vla-get-islayout b) :vlax-false)
      (setq tl (cons (vla-get-name b) tl))
    )
  )
  (reverse tl)
)

Список имен всех внешних ссылок

;;; Список всех имен внешних ссылок
;;; пример возращаемого значения: ("xref1" "x2")
(defun ax:xrefs (/ b bn tl)
  (vlax-for b (vla-get-blocks
                (vla-get-ActiveDocument (vlax-get-acad-object))
              )
    (if (= (vla-get-isxref b) :vlax-true)
      (setq tl (cons (vla-get-name b) tl))
    )
  )
  (reverse tl)
)

Возвращает список с ссылками на определенные блоки

;;; Возвращает список с ссылками на определенные блоки
;;; (blockrefs )
;;; пример использования: (blockrefs "b1")
;;; возвращает: ( )
;;; замечание: если возвращает nil, значит указанных блоков в чертеже нет
(defun blockrefs (bn / lst ed)
  (if (setq ed (tblobjname "block" bn))
    (setq
      lst (entget
            (cdr (assoc 330 (entget ed)))
          )
    )
  )
  (apply
    'append
    (mapcar '(lambda (x)
               (list (cdr x))
             )
            (cdr (reverse (cdr (member (assoc 102 lst) lst))))
    )
  )
)

Возвращает список, содержащий каждую ссылку на данный блок

;;; Возвращает список, содержащий каждую ссылку на указанный блок
;;; Аргументы: строка, которая идентифицирует искомый блок
(defun listblockrefs (blkName / lst)
  (setq	lst (entget
	      (cdr (assoc 330 (entget (tblobjname "block" blkName))))
	    )
  )
  (apply
    'append
    (mapcar '(lambda (x)
	       (if (entget (cdr x))
		 (list (cdr x))
	       )
	     )
	    (cdr (reverse (cdr (member (assoc 102 lst) lst))))
    )
  )
)

Возвращает список, содержащий имена примитивов определений блоков, которые ссылаются на данный блок

;;; Возвращает список, содержащий имена примитивов
;;; oпределений блоков, которые ссылаются на данный блок
;;; Аргументы: строка, которая идентифицирует искомый блок
(defun ax:GetParentBlocks (blkName / doc)
  (vl-load-com)
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (apply
    'append
    (mapcar '(lambda (x)
	       (if (= :vlax-false
		      (vla-get-IsLayout
			(vla-ObjectIdToObject
			  doc
			  (vla-get-OwnerId (vlax-ename->vla-object x))
			)
		      )
		   )
		 (list x)
	       )
	     )
	    (listblockrefs blkName)
    )
  )
)

Удаляет указанные примитивы из определения блока

;;; Удаляет указанные примитивы из определения блока
;;; Аргументы: имя примитива как элемента в определении блока
;;; Возвращает: оставшееся число элементов в определении блока
;;; Для того чтобы изменения стали видимыми, необходимо регенерировать чертеж
(defun ax:DeleteObjectFromBlock	(ent / doc blk)
  (setq	doc (vla-get-ActiveDocument (vlax-get-acad-object))
	ent (vlax-ename->vla-object ent)
	blk (vla-ObjectIdToObject doc (vla-get-OwnerID ent))
  )
  (vla-Delete ent)
  (vla-get-Count blk)
)

Добавляет указанный элемент к данному определению блока

;;; Добавляет указанный элемент к данному определению блока
;;; Аргументы: имя примитива определения блока, набор выбора,
;;;            содержаший добавляемые объекты
;;; Возвращает: nil
;;; Для того чтобы изменения стали видимыми, необходимо регенерировать чертеж
(defun ax:AddObjectsToBlock (blk ss / doc blkref blkdef inspt refpt)
  (setq	doc	(vla-get-ActiveDocument (vlax-get-acad-object))
	blkref	(vlax-ename->vla-object blk)
	blkdef	(vla-Item (vla-get-Blocks doc) (vla-get-Name blkref))
	inspt	(vlax-variant-value (vla-get-InsertionPoint blkref))
	ssarray	(selectionset->array ss)
	refpt	(vlax-3d-point '(0 0 0))
  )
  (foreach ent (vlax-safearray->list ssarray)
    (vla-Move ent inspt refpt)
  )
  (vla-CopyObjects doc ssarray blkdef)
  (foreach ent (vlax-safearray->list ssarray)
    (vla-Delete ent)
  )
  (princ)
)

Конвертирует набор выбора в массив ActiveX

;;; Конвертирует набор выбора в массив ActiveX
(defun selectionset->array (ss / c r)
  (vl-load-com)
  (setq c -1)
  (repeat (sslength ss)
    (setq r (cons (ssname ss (setq c (1+ c))) r))
  )
  (setq r (reverse r))
  (vlax-safearray-fill
    (vlax-make-safearray
      vlax-vbObject
      (cons 0 (1- (length r)))
    )
    (mapcar 'vlax-ename->vla-object r)
  )
)

Находит значение указанного блока и атрибута

;;; (ax:GetTagTextString doc "sheet-text" "client-drw")
(defun ax:GetTagTextString (doc bn tagname / layout i atts tag str)
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (if (and
              (= (vla-get-hasattributes i) :vlax-true)
              (safearray-value
                (setq atts
                       (vlax-variant-value
                         (vla-getattributes i)
                       )
                )
              )
            )    
          (foreach tag (vlax-safearray->list atts)
            (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
              (setq str (vla-get-TextString tag))
            )
          )
        )
      )
    )
  )
  str
)

Находит блок с указанным именем, атрибутом или значением

;;; (ax:FindBlockTagValue (vla-get-activedocument
;;; (vlax-get-acad-object)) "blockname" "tagname" "tagvalue")
(defun ax:FindBlockTagValue
       (doc bn tagname value / layout i atts tag sset c)
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (if (and
              (= (vla-get-hasattributes i) :vlax-true)
              (safearray-value
                (setq atts
                       (vlax-variant-value
                         (vla-getattributes i)
                       )
                )
              )
            )
          (progn
            (foreach tag (vlax-safearray->list atts)
              (if (and
                    (= (strcase tagname)
                       (strcase (vla-get-TagString tag))
                    )
                    (= value (vla-get-TextString tag))
                  )
                (progn
                  (if (not sset)
                    (setq sset (ssadd (vlax-vla-object->ename i)))
                    (ssadd (vlax-vla-object->ename i) sset)
                  )
                )
              )
            )
          )
        )
      )
    )
  )
  (sssetfirst nil sset)
)

Создает список всех блоков с их именами и атрибутами по порядку y-коорлинаты, снизу вверх.

;;; Список всех "REV-NO" в блоке "revtext1" по порядку y-координаты, снизу вверх.
;;; (ax:GetManyTags "revtext1" "REV-NO")
(defun ax:GetManyTags (bn tag / ax lst)
  (foreach x (ax:ListBlockIns doc bn)
    (setq lst (cons (ax:GetTagTextStringByRef (cadddr x) tag) lst))
  )
  (reverse lst)
)

;;; Список всех "REV-NO" в блоке"revtext2" по порядку y-координаты, снизу вверх.
;;; (ax:SetManyTags "revtext2" "revtext1" "REV-NO" "REV-NO")
(defun ax:SetManyTags (bn-to bn-from tag-to tag-from / ax lst i)
  (setq lst (ax:GetManyTags bn-from tag-from))
  (setq i 0)
  (foreach x (ax:ListBlockIns doc bn-to)
    (ax:PutTagTextStringByRef (cadddr x) tag-to (nth i lst))
    (setq i (1+ i))
  )
)

;;; (ax:GetTagTextStringByRef # "REV-NO")
(defun ax:GetTagTextStringByRef (br tagname / atts tag str)
  (if (and
        (= (vla-get-hasattributes br) :vlax-true)
        (safearray-value
          (setq atts
                 (vlax-variant-value
                   (vla-getattributes br)
                 )
          )
        )
      )
    (foreach tag (vlax-safearray->list atts)
      (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
        (setq str (vla-get-TextString tag))
      )
    )
  )
  str
)

;;; (ax:PutTagTextString doc "sheet-text" "client-drw" "new value")
(defun ax:PutTagTextString (doc bn tagname textstring / layout i atts tag)
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (if (and
              (= (vla-get-hasattributes i) :vlax-true)
              (safearray-value
                (setq atts
                       (vlax-variant-value
                         (vla-getattributes i)
                       )
                )
              )
            )    
          (foreach tag (vlax-safearray->list atts)
            (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
              (vla-put-TextString tag textstring)
            )
          )
          (vla-update i)
        )
      )
    )
  )
)

;;; (ax:PutTagTextStringByRef #
;;; "REV-NO" "new value")
(defun ax:PutTagTextStringByRef (br tagname textstring / atts tag)
  (if (and
        (= (vla-get-hasattributes br) :vlax-true)
        (safearray-value
          (setq atts
                 (vlax-variant-value
                   (vla-getattributes br)
                 )
          )
        )
      )
    (foreach tag (vlax-safearray->list atts)
      (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
        (vla-put-TextString tag textstring)
      )
    )
    (vla-update br)
  )
)

Изменяет высоту атрибута

;;; (ax:ChangeTagHeight    )
;;; (ax:ChangeTagHeight doc "sheet-text" "client-drw" 0.97)
(defun ax:ChangeTagHeight (doc bn tagname tagheight / layout i atts tag)
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (if (and
              (= (vla-get-hasattributes i) :vlax-true)
              (safearray-value
              (setq atts
                     (vlax-variant-value
                       (vla-getattributes i)
                     )
              )
            )
             )    
          (foreach tag (vlax-safearray->list atts)
            (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
              (vla-put-height tag tagheight)
            )
          )
          (vla-update i)
        )
      )
    )
  )
)

Список точек вставки и ссылок на блоки в активном листе, отсортированные по y-значению

;;; Список точек вставки и ссылок на блоки в активном листе, 
;;; отсортированные по y-значению
;;; (ax:ListBlockIns doc "revtext1")
;;; Примеры возвращаемых значений:
;;; ((341.385 29.2937 0.0 #)
;;;  (341.385 34.2937 0.0 #)
;;;  (341.385 39.2937 0.0 #))
(defun ax:ListBlockIns (doc bn / layout i pl)
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (setq pl
               (cons
                 (append (safearray-value
                           (vlax-variant-value (vla-get-InsertionPoint i))
                         )
                         (list i)
                 )
                 pl
               )
        )
      )
    )
  )
  ; sort by y-value
  (vl-sort pl 
             (function (lambda (e1 e2) 
                         (< (cadr e1) (cadr e2)) ) ) )
)

Изменяет точку вставки тэга

;;; Изменяет точку вставки тэга
;;; (ax:ChangeTagIns doc "sheet-text" "a3-scale" '(703.4722 17.8350 0))
(defun ax:ChangeTagIns (doc bn tagname ins / layout i atts tag)
  (defun list->variantArray (ptsList / arraySpace sArray)
    (setq arraySpace
      (vlax-make-safearray
        vlax-vbdouble
        (cons 0 (- (length ptsList) 1))
      )
    )
    (setq sArray (vlax-safearray-fill arraySpace ptsList))
    (vlax-make-variant sArray)
  )
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (if (and
              (= (vla-get-hasattributes i) :vlax-true)
              (safearray-value
              (setq atts
                     (vlax-variant-value
                       (vla-getattributes i)
                     )
              )
            )
             )    
          (foreach tag (vlax-safearray->list atts)
            (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
              (vla-put-InsertionPoint tag (list->variantArray ins))
            )
          )
          (vla-update i)
        )
      )
    )
  )
)

Изменяет атрибуты на всех ссылках блоков, соответствующих указанному имени
;;; Изменяет атрибуты на всех ссылках блоков, соответствующих 
;;; (ChangeAttributes (list  '( . ) ...))
;;; (ChangeAttributes (list "testblock" '("TESTTAG2" . "item1") '("NEWTAG" . "tagvalue")))
(defun ChangeAttributes (lst / sset item atts ename i)
  (setq i 0)
  (setq sset (ssget "X" (list '(0 . "INSERT") (cons 2 (car lst)))))
  (if sset
    (repeat (sslength sset)
      (setq ename (ssname sset i))
      (setq i (+ 1 i))
      (if (safearray-value
            (setq atts
                   (vlax-variant-value
                     (vla-getattributes (vlax-ename->vla-object ename))
                   )
            )
          )
        (progn
          (foreach item (cdr lst)
            (mapcar
              '(lambda (x)
                 (if
                   (= (strcase (car item))
                      (strcase (vla-get-tagstring x))
                   )
                    (vla-put-textstring x (cdr item))
                 )
               )
              (vlax-safearray->list atts)
            )
          )
          (vla-update (vlax-ename->vla-object ename))
        )
      )
    )
  )
)

Изменяет ширину атрибута

;;; (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
;;; (ax:ChangeTagWidth    )
;;; (ax:ChangeTagWidth doc "panel1" "drw-no" 0.97)
(defun ax:ChangeTagWidth (doc bn tagname tagwidth / layout i atts tag)
  (vlax-for layout (vla-get-layouts doc)
    (vlax-for i (vla-get-block layout)
      (if (and
            (= (vla-get-objectname i) "AcDbBlockReference")
            (= (strcase (vla-get-name i)) (strcase bn))
          )
        (if (and
              (= (vla-get-hasattributes i) :vlax-true)
              (safearray-value
              (setq atts
                     (vlax-variant-value
                       (vla-getattributes i)
                     )
              )
            )
             )    
          (foreach tag (vlax-safearray->list atts)
            (if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
              (vla-put-scalefactor tag tagwidth)
            )
          )
          (vla-update i)
        )
      )
    )
  )
)

						Translate to:
Обратная связь	Новости САПР	Программы	Документация	Полезные советы	Обзорные статьи
Заказ и разработка	Каталог САПР	САПР-конференция	Библиотека ГОСТов	Наши соавторы	Коммерческое ПО