Code lisp về thao tác với block trong bản vẽ

[Nguyen Hoanh 4.663]

Có một thư viện thao tác block khá hay, mọi người có thể tham khảo khi viết chương trình thao tác với block.

 

Thư viện này sẽ làm các công việc:

Erases all blocks with a specific name

Xóa các block với tên cho trước

Test if specified named block exist

Kiểm tra xem block đã tồn tại chưa

Rename block

đổi tên block

List of all block names

liệt kê tên các block

List of all xref names

liệt kê tên các xref

Returns a list with references to a given block

trả về danh sách các trỏ đến block đã cho

Returns a list containing every reference to a given block

trả về danh sách các các liên kết trong block đã cho

Returns a list containing the entity names of block definitions that reference a given block

trả về danh sách chứa tên các đối tượng trong bảng định nghĩa block trỏ tới block đã cho

Deletes the specified subentity from its block definition

Xóa các đối tượng con được chỉ định trong bảng định nghĩa của block đã cho

Adds the specified item to a given block definition

Thêm các đối tượng được chỉ định vào bảng định nghĩa của block đã cho

Convert a selection set to an ActiveX array

Chuyển đổi tập chọn thành mảng ActiveX

Find the value of specified block and attribute

Tìm giá trị của block và attribute được chỉ định

Find a block with a specified name, attribute and value

Tìm một block với tên, attribute như giá trị đã cho

List of all blocks with specified name and attribute in order of y-coordinate, bottom to up

Liệt kê tất cả các tên được chỉ định và thuộc tính trong thứ tự tăng dần của tọa độ Y

Change attribute value in specified block with specified attribute value

Thay đổi giá trị attribute trong block được chỉ định sang một giá trị khác

Change attribute height

Đổi chiều cao Attribute

List the insertion point and reference of a block in active layout sort them by y-value

Liệt kê các điểm chèn và reference của một block trong layout hiện tại, sắp xếp theo giá trị tọa độ y

Changes the insertion point of a tag

Thay đổi điềm chèn của một tag (là attribute trong bảng định nghĩa block)

Changes attributes on all block references matching specified name

Thay đổi attribute trong tất cả các block mà khớp với tên đã cho

Change attribute width

Đổi bề rộng cảu attribute

 

;;; By Jimmy Bergmark
;;; Copyright © 1997-2006 JTB World, All Rights Reserved
;;; Website: www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;; Updated: 2003-02-24
;;;

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

;;; Erases all blocks named "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) 
     )
   )
 )
)

;;; Test if block named "revtext2" exist
;;; (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
)

;;; Rename block from "revtext" to "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)
     )
   )
 )
)

;;; a list of all block names
;;; return example ("*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)
)

;;; a list of all xref names
;;; return example ("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)
)

;;; Returns a list with references to a given block
;;; (blockrefs )
;;; example: (blockrefs "b1")
;;; return: ()
;;; tip: if return is nil it's not inserted
(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))))
   )
 )
)

;;; Returns a list containing every reference to a given block
;;; Arguments: a string identifying the block to search for
(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))))
   )
 )
)

;;; Returns a list containing the entity names
;;; of block definitions that reference a given block
;;; Arguments: a string identifying the block to search for
(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)
   )
 )
)

;;; Deletes the specified subentity from its block definition
;;; Arguments: the entity name of an item within a block reference
;;; Returns: the remaining item count of the block definition
;;; The drawing must be regenerated for the change to become visible
(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)
)

;;; Adds the specified item to a given block definition
;;; Arguments: the entity name of a block reference
;;;            a selection set containing the objects to add
;;; Returns: nil
;;; The drawing must be regenerated for the change to become visible
(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)
)

;;; Utility routine to convert a selection set to an ActiveX array
(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)
)

;;; list of all "REV-NO" in block "revtext1" in order of y-coordinate, bottom to up
;;; (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)
)

;;; list of all "REV-NO" in block "revtext2" in order of y-coordinate, bottom to up
;;; (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)
       )
     )
   )
 )
)

;;; List the insertion point and reference of a block in active layout
;;; sort them by y-value
;;; (ax:ListBlockIns doc "revtext1")
;;; return value example:
;;; ((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) 
                        ()

;;; Changes the insertion point of a tag
;;; (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)
       )
     )
   )
 )
)

;;; Changes attributes on all block references matching 
;;; (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)
       )
     )
   )
 )
)

[svba1608 627]

Lisp trên rất hay, nhưng em không sử dụng được. Xin hỏi bác Hoành và mọi người: lệnh dùng cho lisp này là như thế nào?

Có phải dòng chữ sau "defun ax", ví dụ: "EraseBlock".

Sau khi em apload lisp và gõ "Eraseblock" thì nhận được thông báo: Unknown command "ERASEBLOCK". Press F1 for help.

Còn khi gõ "Renameblock" thì nhận được thông báo: ; error: too few arguments

Rất mong nhận được giải đáp, thanks!

[Tue_NV 3.912]

Lisp trên rất hay, nhưng em không sử dụng được. Xin hỏi bác Hoành và mọi người: lệnh dùng cho lisp này là như thế nào?

Có phải dòng chữ sau "defun ax", ví dụ: "EraseBlock".

Sau khi em apload lisp và gõ "Eraseblock" thì nhận được thông báo: Unknown command "ERASEBLOCK". Press F1 for help.

Còn khi gõ "Renameblock" thì nhận được thông báo: ; error: too few arguments

Rất mong nhận được giải đáp, thanks!

Đây là điểm mà Tue_NV còn thắc mắc.

Mình chưa rõ : (defun ax: .... lắm

Mong bác Hoành, bác ssg và các bác trên diễn đàn giải thích hộ

Xin chân thành cảm ơn rất nhiều

[gia_bach 1.549]

Đây là điểm mà Tue_NV còn thắc mắc.

Mình chưa rõ : (defun ax: .... lắm

Mong bác Hoành, bác ssg và các bác trên diễn đàn giải thích hộ

Xin chân thành cảm ơn rất nhiều

Chào Tue_NV

ax: có thể chỉ là cách phân lọai các hàm khác nhau khi đặt tên.

vd : Tue_NV có thể đặt tên 1 hàm là Tue_NV:chonTxt bằng cách (defun Tue_NV:chonTxt() .... )

 

Lisp trên rất hay, nhưng em không sử dụng được. Xin hỏi bác Hoành và mọi người: lệnh dùng cho lisp này là như thế nào?

Có phải dòng chữ sau "defun ax", ví dụ: "EraseBlock".

Sau khi em apload lisp và gõ "Eraseblock" thì nhận được thông báo: Unknown command "ERASEBLOCK". Press F1 for help.

Còn khi gõ "Renameblock" thì nhận được thông báo: ; error: too few arguments

Rất mong nhận được giải đáp, thanks!

minh họa việc sử dụng hàm ax:EraseBlock

;;; Erases all blocks named "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) 
     )
   )
 )
)

(defun c:test (/ doc blmau ten)
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
Blmau (car(entsel "\n Pick chon Block mau :"))
ten (cdr(assoc 2 (entget Blmau))))
 ;xoa tat ca cac block co block name = ten
 (ax:EraseBlock doc ten)
 )

[nataca 554]

Đây là điểm mà Tue_NV còn thắc mắc.

Mình chưa rõ : (defun ax: .... lắm

Mong bác Hoành, bác ssg và các bác trên diễn đàn giải thích hộ

Xin chân thành cảm ơn rất nhiều

Theo em ax:EraseBlock đơn thuần chỉ là 1 hàm con có tên như thế. Tức là muốn dùng hàm này thì đánh lệnh (ax:EraseBlock) thôi. Tiền tố ax: tác giả dùng để phân biệt với các nhóm hàm con khác

[Polyline 19]

Các hàm con này có làm việc bên trong Block không bác, ví dụ như khi ra lệnh xóa BlockA thì nó có xóa BlockA ra khỏi các Block khác luôn không?