­

More Free AutoLISP and Visual LISP code snippets for AutoCAD

Erases all blocks with a specific name
Test if specified named block exist
Rename block
List of all block names
List of all xref names
Returns a list with references to a given block
Returns a list containing every reference to a given block
Returns a list containing the entity names of block definitions that reference a given block
Deletes the specified subentity from its block definition
Adds the specified item to a given block definition
Convert a selection set to an ActiveX array
Find the value of specified block and attribute
Find a block with a specified name, attribute and value
List of all blocks with specified name and attribute in order of y-coordinate, bottom to up
Change attribute value in specified block with specified attribute value
Change attribute height
List the insertion point and reference of a block in active layout sort them by y-value
Changes the insertion point of a tag
Changes attributes on all block references matching specified name
Change attribute width on specified block name and attribute name
Updates the attribute tag with everywhere in the drawing


 Click here to download the code as a file.

 

;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2016 JTB World Inc., All Rights Reserved
;;; Website: http://jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;; Updated: 2016-05-26
;;; To support dynamic blocks use vla-get-effectivename instead of vla-get-name
;;;

;;; (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 <block name>)
;;; example: (blockrefs "b1")
;;; return: (<Entity name: 2ea6290> <Entity name: 2ea6288>)
;;; 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 #<VLA-OBJECT IAcadBlockReference 071b9e24> "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 #<VLA-OBJECT IAcadBlockReference 071b9e24>
;;; "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 <doc> <block name> <tag name> <tag height>)
;;; (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 #<VLA-OBJECT IAcadBlockReference 071b9e24>)
;;;  (341.385 34.2937 0.0 #<VLA-OBJECT IAcadBlockReference 071b9e74>)
;;;  (341.385 39.2937 0.0 #<VLA-OBJECT IAcadBlockReference 071bd184>))
(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)) ) ) )
)

;;; 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 <Tag Name>
;;; (ChangeAttributes (list <Block Name> '(<Tag Name> . <Tag Value>) ...))
;;; (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 sset nil)
)

;;; (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
;;; (ax:ChangeTagWidth <doc> <block name> <tag name> <tag height>)
;;; (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)
        )
      )
    )
  )
)

;;; Updates the attribute tag with everywhere in the drawing ;;; (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) ;;; (ax:ChangeTagWidthAll <doc> <tag height>) ;;; (ax:ChangeTagWidthAll doc 0.5) (defun ax:ChangeTagWidthAll (doc tagwidth / layout i atts tag) (vlax-for layout (vla-get-layouts doc) (vlax-for i (vla-get-block layout) (if (= (vla-get-objectname i) "AcDbBlockReference") (if (and (= (vla-get-hasattributes i) :vlax-true) (safearray-value (setq atts (vlax-variant-value (vla-getattributes i) ) ) ) ) (foreach tag (vlax-safearray->list atts) (vla-put-scalefactor tag tagwidth) ) (vla-update i) ) ) ) ) )
 
Have any questions? Contact us

­