- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
I could use some help modifying Lee Mac's Automatic Block Break LISP to allow the selection of similar blocks. Currently you can select a single block (ABBE) or (ABBS) multiselect blocks. I need to select all blocks identical to right clicking "select similar" or by entering the block Name which then selects all instances of that block with in a drawing.
Thanks in advance
Link to LISP
http://www.lee-mac.com/autoblockbreak.html
Code from LISP file
;;---------------------=={ Automatic Block Break }==--------------------;;
;; ;;
;; This program enables the user to insert a block at a specified ;;
;; point, with surrounding geometry trimmed to the rectangular outline ;;
;; of the block. Optionally, the program will automatically rotate ;;
;; the block to align with a curve object passing through the block ;;
;; insertion point. ;;
;; ;;
;; The program first prompts the user to select a block to insert. At ;;
;; this prompt the user may select a block from the drawing, or type ;;
;; 'Browse' to browse for a drawing file to insert. The user may also ;;
;; alter the program rotation setting by typing 'Rotation' at the ;;
;; prompt. ;;
;; ;;
;; Following a valid response, the program prompts the user to specify ;;
;; an insertion point for the block. ;;
;; ;;
;; If a curve object (Arc, Elliptical Arc, Ellipse, Circle, Line, ;;
;; XLine, Spline, LWPolyline or Polyline) is detected at the block ;;
;; insertion point and the program rotation setting is enabled, the ;;
;; inserted block is automatically rotated to align with the curve. ;;
;; ;;
;; All surrounding compatible objects found to intersect with the ;;
;; inserted block are then trimmed to the rectangular block outline. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.0 - 2010-11-22 ;;
;; ;;
;; - First release. ;;
;;----------------------------------------------------------------------;;
;; Version 1.1 - 2011-02-07 ;;
;; ;;
;; - Entire program rewritten to allow subfunction to be called with ;;
;; block object argument. ;;
;; - Multiple intersecting objects are now trimmed. ;;
;;----------------------------------------------------------------------;;
;; Version 1.2 - 2011-02-08 ;;
;; ;;
;; - Changed block insertion to Visual LISP InsertBlock method. ;;
;; - Added calling functions to trim blocks in-situ (ABBE / ABBS). ;;
;;----------------------------------------------------------------------;;
;; Version 1.3 - 2011-08-03 ;;
;; ;;
;; - Altered method used to create bounding polyline to exclude ;;
;; attributes when trimming objects surrounding block. ;;
;; - Objects surrounding blocks whose insertion point does not lie on ;;
;; a curve are now also trimmed. ;;
;;----------------------------------------------------------------------;;
;; Version 1.4 - 2011-09-30 ;;
;; ;;
;; - Added option to enable/disable automatic block rotation. ;;
;; - Updated code formatting. ;;
;;----------------------------------------------------------------------;;
;; Version 1.5 - 2013-03-04 ;;
;; ;;
;; - Fixed bug causing program to attempt to break MLines. ;;
;; - Added new LM:blockboundingbox function to correctly calculate ;;
;; the bounding box of Dynamic Block references. ;;
;; - Entire program rewritten. ;;
;;----------------------------------------------------------------------;;
;; Version 1.6 - 2013-10-01 ;;
;; ;;
;; - Fixed a bug causing the program to return an error if an object ;;
;; intersects the block bounding box at only one point. ;;
;;----------------------------------------------------------------------;;
;; Version 1.7 - 2014-11-22 ;;
;; ;;
;; - Changed the method used to detect objects located at the block ;;
;; insertion point when determining the angle for automatic ;;
;; block rotation. ;;
;;----------------------------------------------------------------------;;
;; Version 1.8 - 2017-10-09 ;;
;; ;;
;; - Revised calculation of block bounding box to ignore objects ;;
;; residing on frozen layers. ;;
;; - Added option to specify block name at command-line. ;;
;;----------------------------------------------------------------------;;
;; Version 1.9 - 2020-11-14 ;;
;; ;;
;; - Revised calculation of block rotation angle to account for ;;
;; insertion points located at the end points of the supplied curve. ;;
;;----------------------------------------------------------------------;;
(defun c:abb ( / *error* blk obj ins sel tmp )
(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(cond
( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
(princ "\nCurrent layer locked.")
)
( (progn
(while
(not
(progn
(setvar 'errno 0)
(initget "Browse Name Rotation")
(princ (strcat "\nAutomatic Block Rotation: " (getenv "LMac\\ABBRotation")))
(setq sel
(entsel
(strcat "\nSelect Block [Browse/Name/Rotation]"
(if (= "" (setq blk (getvar 'insname)))
": "
(strcat " <" blk ">: ")
)
)
)
)
(cond
( (= 7 (getvar 'errno))
(prompt "\nMissed, Try Again.")
)
( (null sel)
(not (if (= "" blk) (setq blk nil)))
)
( (= "Rotation" sel)
(initget "ON OFF")
(setenv "LMac\\ABBRotation"
(cond
( (getkword
(strcat "\nAutomatic Block Rotation [ON/OFF] <"
(getenv "LMac\\ABBRotation") ">: "
)
)
)
( (getenv "LMac\\ABBRotation") )
)
)
nil
)
( (= "Name" sel)
(while
(not
(or
(= ""
(setq tmp
(getstring t
(strcat "\nSpecify block name"
(if (= "" blk) ": " (strcat " <" blk ">: "))
)
)
)
)
(tblsearch "block" tmp)
)
)
(princ (strcat "\nBlock \"" tmp "\" is not defined in the current drawing."))
)
(cond
( (/= "" tmp) (setq blk tmp))
( (/= "" blk))
)
)
( (= "Browse" sel)
(setq blk (getfiled "Select Block" "" "dwg" 16))
)
( (listp sel)
(if (/= "INSERT" (cdr (assoc 0 (entget (car sel)))))
(prompt "\nObject must be a block.")
(setq obj (vla-copy (vlax-ename->vla-object (car sel)))
blk (LM:blockname obj)
)
)
)
)
)
)
)
(not (or blk obj))
)
)
( (setq ins (getpoint (strcat "\nSpecify insertion point for " (vl-filename-base blk) " block: ")))
(LM:startundo (LM:acdoc))
(if (null obj)
(setq obj
(vla-insertblock
(vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
(vlax-3D-point (trans ins 1 0))
blk
1.0
1.0
1.0
(angle '(0.0 0.0 0.0) (trans (getvar 'ucsxdir) 0 (trans '(0.0 0.0 1.0) 1 0 t) t))
)
)
)
(if blk (setvar 'insname (vl-filename-base blk)))
(vla-put-insertionpoint obj (vlax-3D-point (trans ins 1 0)))
(LM:autoblockbreak (vlax-vla-object->ename obj) (= "ON" (getenv "LMac\\ABBRotation")))
(LM:endundo (LM:acdoc))
)
)
(princ)
)
;;----------------=={ Automatic Block Break Existing }==----------------;;
;; ;;
;; This program enables the user to select an existing block and trim ;;
;; all surrounding geometry to the rectangular outline of the block. ;;
;; Optionally, the program will automatically rotate the selected ;;
;; block to align with a curve object passing through the block ;;
;; insertion point. ;;
;; ;;
;; At the block selection prompt, the user may also alter the program ;;
;; rotation setting by typing 'Rotation' when prompted. ;;
;; ;;
;; If a curve object (Arc, Elliptical Arc, Ellipse, Circle, Line, ;;
;; XLine, Spline, LWPolyline or Polyline) is detected at the block ;;
;; insertion point of the selected block and the program rotation ;;
;; setting is enabled, the block is automatically rotated to align ;;
;; with the curve. ;;
;; ;;
;; All surrounding compatible objects found to intersect with the ;;
;; selected block are then trimmed to the rectangular block outline. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
(defun c:abbe ( / *error* enx sel )
(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(while
(progn
(setvar 'errno 0)
(initget "Rotation")
(princ (strcat "\nAutomatic Block Rotation: " (getenv "LMac\\ABBRotation")))
(setq sel (entsel "\nSelect Block to Trim [Rotation]: "))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, Try Again.")
)
( (= "Rotation" sel)
(initget "ON OFF")
(setenv "LMac\\ABBRotation"
(cond
( (getkword
(strcat "\nAutomatic Block Rotation [ON/OFF] <"
(getenv "LMac\\ABBRotation") ">: "
)
)
)
( (getenv "LMac\\ABBRotation") )
)
)
)
( (= 'ename (type (car sel)))
(cond
( (/= "INSERT" (cdr (assoc 0 (setq enx (entget (car sel))))))
(princ "\nObject must be a block.")
)
( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (cdr (assoc 8 enx)))))))
(princ "\nSelected block is on a locked layer.")
)
( t
(LM:startundo (LM:acdoc))
(LM:AutoBlockBreak (car sel) (= "ON" (getenv "LMac\\ABBRotation")))
(LM:endundo (LM:acdoc))
)
)
t
)
)
)
)
(princ)
)
;;---------------=={ Automatic Block Break Selection }==----------------;;
;; ;;
;; This program enables the user to select multiple existing blocks ;;
;; and automatically trim all surrounding geometry to the rectangular ;;
;; outline of each block. Optionally, the program will automatically ;;
;; rotate each block in the selection to align with curve objects ;;
;; detected to pass through the block insertion point. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
(defun c:abbs ( / *error* inc rot sel )
(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq rot (= "ON" (getenv "LMac\\ABBRotation")))
(if (setq sel (ssget "_:L" '((0 . "INSERT"))))
(progn
(LM:startundo (LM:acdoc))
(repeat (setq inc (sslength sel))
(LM:AutoBlockBreak (ssname sel (setq inc (1- inc))) rot)
)
(LM:endundo (LM:acdoc))
)
)
(princ)
)
;;---------------=={ Automatic Block Break SubFunction }==--------------;;
;; ;;
;; Upon calling the function with a VLA Block Reference Object ;;
;; argument, the function will trim all surrounding compatible ;;
;; geometry found to intersect with the rectangular outline of the ;;
;; supplied block reference. ;;
;; ;;
;; Furthermore, if a curve object is detected to pass through (or in ;;
;; the vicinity of) the block insertion point and the rotation flag ;;
;; argument holds a non-nil value, the supplied block reference is ;;
;; rotated to align with the curve. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Arguments: ;;
;; ent - Block Reference Entity ;;
;; rot - Rotation flag (if T, block is aligned to curve) ;;
;;----------------------------------------------------------------------;;
(defun LM:autoblockbreak ( ent rot / *error* _furthestapart ang bbx brk cmd crv di1 di2 enx idx ins int lst ply sel tmp )
(defun *error* ( msg )
(if (and (= 'vla-object (type ply)) (vlax-write-enabled-p ply))
(vla-delete ply)
)
(if (= 'int (type cmd))
(setvar 'cmdecho cmd)
)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(defun _furthestapart ( lst / dis mxd out pt1 pt2 )
(setq mxd 0.0)
(while (setq pt1 (car lst))
(foreach pt2 (setq lst (cdr lst))
(if (< mxd (setq dis (distance pt1 pt2)))
(setq mxd dis
out (list pt1 pt2)
)
)
)
)
out
)
(if (and (= 'ename (type ent))
(setq enx (entget ent))
(= "INSERT" (cdr (assoc 0 enx)))
)
(progn
(if
(and
rot
(setq bbx (LM:blockboundingbox (vlax-ename->vla-object ent)))
(setq sel
(ssget "_C"
(trans (car bbx) 0 1)
(trans (caddr bbx) 0 1)
'((0 . "ARC,ELLIPSE,CIRCLE,LINE,XLINE,SPLINE,*POLYLINE"))
)
)
(progn
(setq ins (trans (cdr (assoc 10 enx)) ent 0)
crv (ssname sel (1- (sslength sel)))
di1 (distance ins (vlax-curve-getclosestpointto crv ins))
)
(repeat (setq idx (1- (sslength sel)))
(setq tmp (ssname sel (setq idx (1- idx))))
(if (< (setq di2 (distance ins (vlax-curve-getclosestpointto tmp ins))) di1)
(setq di1 di2
crv tmp
)
)
)
(< di1 1e-4)
)
(setq par (vlax-curve-getparamatpoint crv (vlax-curve-getclosestpointto crv ins)))
(cond
( (equal par (vlax-curve-getendparam crv) 1e-8)
(setq par (vlax-curve-getparamatdist crv (- (vlax-curve-getdistatparam crv par) 1e-3)))
)
( (equal par (vlax-curve-getstartparam crv) 1e-8)
(setq par (vlax-curve-getparamatdist crv (+ (vlax-curve-getdistatparam crv par) 1e-3)))
)
( t )
)
(setq der (vlax-curve-getfirstderiv crv par))
(setq ang (angle '(0.0 0.0 0.0) (trans der 0 (cdr (assoc 210 (entget crv))))))
(or (<= ang (/ pi 2.0))
(< (/ (* 3.0 pi) 2.0) ang)
(setq ang (+ ang pi))
)
)
(vla-put-rotation (vlax-ename->vla-object ent) ang) ;; VL used to account for attributes
)
(if
(and
(setq bbx (LM:blockboundingbox (vlax-ename->vla-object ent)))
(setq sel
(ssget "_C"
(trans (car bbx) 0 1)
(trans (caddr bbx) 0 1)
'((0 . "ARC,ELLIPSE,CIRCLE,LINE,XLINE,SPLINE,*POLYLINE"))
)
)
)
(progn
(setq ply
(vlax-ename->vla-object
(entmakex
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 38 (cadddr (assoc 10 enx)))
)
(mapcar '(lambda ( p ) (mapcar '+ (cons 10 (trans p 0 ent)) '(0 0 0))) bbx)
(list (assoc 210 enx))
)
)
)
)
(repeat (setq idx (sslength sel))
(setq ent (ssname sel (setq idx (1- idx))))
(if (setq int (LM:Intersections (vlax-ename->vla-object ent) ply acextendthisentity))
(setq lst (cons (cons ent int) lst))
)
)
(vla-delete ply)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(foreach int lst
(if (setq brk (_furthestapart (cdr int)))
(command
"_.break" (list (car int) (trans (car brk) 0 1)) "_F"
"_non" (trans (car brk) 0 1)
"_non" (trans (cadr brk) 0 1)
)
)
)
(setvar 'cmdecho cmd)
)
)
)
)
(princ)
)
;; Intersections - Lee Mac
;; Returns a list of all points of intersection between two objects.
;; obj1,obj2 - [vla] VLA-Objects with intersectwith method applicable
;; mode - [int] acextendoption enum of intersectwith method
;; Returns: [lst] List of 3D WCS intersection points, else nil
(defun LM:intersections ( obj1 obj2 mode / l r )
(setq l (vlax-invoke obj1 'intersectwith obj2 mode))
(repeat (/ (length l) 3)
(setq r (cons (list (car l) (cadr l) (caddr l)) r)
l (cdddr l)
)
)
(reverse r)
)
;;-------------------=={ Block BoundingBox }==----------------;;
;; ;;
;; Returns a point list describing a rectangular frame ;;
;; bounding all geometry of a supplied block reference. ;;
;; Excludes Text, MText & Attribute Definitions. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; blk - VLA Block Reference Object ;;
;;------------------------------------------------------------;;
;; Returns: WCS Point list describing boundingbox of block ;;
;;------------------------------------------------------------;;
(defun LM:blockboundingbox ( blk / bnm llp lst urp )
(setq bnm (strcase (vla-get-name blk)))
(cond
( (setq lst (cdr (assoc bnm LM:blockboundingbox:cache))))
( (progn
(vlax-for obj (vla-item (LM:acblk) bnm)
(cond
( (= "AcDbBlockReference" (vla-get-objectname obj))
(setq lst (append lst (LM:blockboundingbox obj)))
)
( (and
(= :vlax-true (vla-get-visible obj))
(not (wcmatch (vla-get-objectname obj) "AcDbAttributeDefinition,AcDb*Text"))
(vlax-method-applicable-p obj 'getboundingbox)
(= :vlax-false (vla-get-freeze (vla-item (LM:aclyr) (vla-get-layer obj))))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
)
(setq lst (vl-list* (vlax-safearray->list llp) (vlax-safearray->list urp) lst))
)
)
)
lst
)
(setq lst (mapcar '(lambda ( fun ) (apply 'mapcar (cons fun lst))) '(min max)))
(setq lst
(list
(car lst)
(list (caadr lst) (cadar lst))
(cadr lst)
(list (caar lst) (cadadr lst))
)
)
(setq LM:blockboundingbox:cache (cons (cons bnm lst) LM:blockboundingbox:cache))
)
)
(apply
(function
(lambda ( m v )
(mapcar (function (lambda ( p ) (mapcar '+ (mxv m p) v))) lst)
)
)
(refgeom (vlax-vla-object->ename blk))
)
)
;; RefGeom (gile)
;; Returns a list which first item is a 3x3 transformation matrix (rotation,
;; scales, normal) and second item the object insertion point in its parent
;; (xref, block or space)
;;
;; Argument : an ename
(defun refgeom ( ent / ang ang mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(mapcar '(lambda ( v ) (trans v 0 ocs t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
(mxm
(list
(list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(list
(list (cdr (assoc 41 enx)) 0.0 0.0)
(list 0.0 (cdr (assoc 42 enx)) 0.0)
(list 0.0 0.0 (cdr (assoc 43 enx)))
)
)
)
)
(mapcar '- (trans (cdr (assoc 10 enx)) ocs 0)
(mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
)
)
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Block Name - Lee Mac
;; Returns the true (effective) name of a supplied block reference
(defun LM:blockname ( obj )
(if (vlax-property-available-p obj 'effectivename)
(defun LM:blockname ( obj ) (vla-get-effectivename obj))
(defun LM:blockname ( obj ) (vla-get-name obj))
)
(LM:blockname obj)
)
;; Start Undo - Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)
;; End Undo - Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)
;; Active Document - Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
;; Block Collection - Lee Mac
;; Returns the VLA Block Collection Object
(defun LM:acblk nil
(eval (list 'defun 'LM:acblk 'nil (vla-get-blocks (LM:acdoc))))
(LM:acblk)
)
;; Layer Collection - Lee Mac
;; Returns the VLA Layer Collection Object
(defun LM:aclyr nil
(eval (list 'defun 'LM:aclyr 'nil (vla-get-layers (LM:acdoc))))
(LM:aclyr)
)
;;----------------------------------------------------------------------;;
(if (null (getenv "LMac\\ABBRotation"))
(setenv "LMac\\ABBRotation" "ON")
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
(strcat
"\n:: AutoBlockBreak.lsp | Version 1.9 | \\U+00A9 Lee Mac "
((lambda ( y ) (if (= y (menucmd "m=$(edtime,0,yyyy)")) y (strcat y "-" (menucmd "m=$(edtime,0,yyyy)")))) "2010")
" www.lee-mac.com ::"
"\n:: \"ABB\" - Insert & Break | \"ABBE\"/\"ABBS\" - Break Existing ::"
)
)
(princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
Solved! Go to Solution.
