;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Block Overkill ;;; ;;; Created by Jonathan Handojo ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; This program allows the user to either delete blocks that may have been accidentally ;;; ;;; placed on top of one another (similar to the OVERKILL command), or move them to a user- ;;; ;;; specified layer. The command will proceed to process blocks that shares the same insertion ;;; ;;; point effective name, and effective scale. This is then followed by a circle of a desired ;;; ;;; radius drawn in the insertion points of the deleted block in the "BOVERKILL-Duplicates" ;;; ;;; layer, and the program will also report the number of blocks that have been processed into ;;; ;;; the command dline. If your block is dynamic with modified properties, the original ;;; ;;; OVERKILL command won't be able to catch the blocks as it does not have a defined block ;;; ;;; name. As such, this command will catch blocks through effective name of the block. ;;; ;;; ;;; ;;; This program proceeds to process blocks sharing the same insertion point through a ;;; ;;; specific fuzz, and effective name, and scale. So, beware that blocks that shares the ;;; ;;; criteria states but is rotated differently will still be deleted. The reason this was not ;;; ;;; accounted for is because objects when an object is mirrored using the MIRROR command, ;;; ;;; rotation values are adjusted, and it's not possible to determined if an object is mirrored ;;; ;;; (at least from my one-year experience of AutoLISP coding). Depending on the mode of the ;;; ;;; BOVERKILL set, the program performs different calculation to determine the duplicates. ;;; ;;; ;;; ;;; This inspiration comes from using Lee Mac's Block Counter code reporting incorrect values ;;; ;;; due to blocks being duplicated on top of another. With thousands of blocks present in the ;;; ;;; drawing, it's almost impossible to check for block duplicates, thus I programmed this ;;; ;;; piece of LISP to help me with take-off values. Type BOVERKILL to invoke command. As more ;;; ;;; ideas are recommended from the CADTutor forum, the program has been upgraded over time. ;;; ;;; ;;; ;;; ------------------------------------------------------------ ;;; ;;; BOVERKILL Modes ;;; ;;; ------------------------------------------------------------ ;;; ;;; ;;; ;;; This program has three modes of overkill: ;;; ;;; ;;; ;;; 1. Distance ;;; ;;; 2. Plane-Axis ;;; ;;; 3. Axes ;;; ;;; ;;; ;;; ----------------- ;;; ;;; Distance ;;; ;;; ----------------- ;;; ;;; ;;; ;;; This is the most common type of overkill that is most widely used. This overkill considers ;;; ;;; two blocks a duplicate if the two blocks dwell within the specified tolerance of each ;;; ;;; other. ;;; ;;; ;;; ;;; ----------------- ;;; ;;; Plane-Axis ;;; ;;; ----------------- ;;; ;;; ;;; ;;; This mode considers two blocks as a duplicate if the two blocks dwell within one specified ;;; ;;; tolerance along one plane, and a different specified tolerance along the third axis of ;;; ;;; that plane of each other. The program will use the current UCS for calculation. ;;; ;;; ;;; ;;; ----------------- ;;; ;;; Distance ;;; ;;; ----------------- ;;; ;;; ;;; ;;; This mode considers two blocks as a duplicate if the two blocks dwell within individual ;;; ;;; tolerances specified along each axis of the place of each other. Similar to the Plane-Axis ;;; ;;; mode, the program will use the current UCS to attempt the calculations. ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Versions and Updates ;;; ;;; ------------------------------------------------------------ ;;; ;;; ;;; ;;; Version 1.0 (15/04/20) � First release ;;; ;;; ;;; ;;; ------------------------------------ ;;; ;;; ;;; ;;; Version 1.1 (16/04/2020) ;;; ;;; ;;; ;;; - Added an option to move the duplicated blocks to a layer of a specified choice. ;;; ;;; ;;; ;;; ------------------------------------ ;;; ;;; ;;; ;;; Version 1.2 (25/04/2020) ;;; ;;; ;;; ;;; - Bug fix due to variable setting errors. ;;; ;;; ;;; ;;; ------------------------------------ ;;; ;;; ;;; ;;; Version 1.3 (20/04/2023) ;;; ;;; ;;; ;;; - Program rewritten to include the overkill mode. ;;; ;;; - Bug fixes to ensure proper layer naming when prompted for a layer name. ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun BlockOverkill:Settings ( / ) '( ;|00|; "BOVERKILL-Duplicates" ;; The layer to draw the circles for block duplicates. ;|01|; 60 ;; The radius of the circle ;|02|; 1 ;; AutoCAD Color Index of the circle. (nil to use ByLayer, 0 to use ByBlock) ) ) (defun c:boverkill (/ *error* acadobj activeundo adoc del dp enx ly mod pck spc ss tol1 tol2 tol3 x) (defun *error* ( msg ) (vla-EndUndoMark adoc) (if pck (setvar "PICKADD" pck)) (if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*")) (princ (strcat "Error: " msg)) ) ) (setq acadobj (vlax-get-acad-object) adoc (vla-get-ActiveDocument acadobj) spc (vla-get-Block (vla-get-ActiveLayout adoc)) ) (setq pck (getvar "PICKADD")) (setvar "PICKADD" 2) (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T)) (and (setq ss (ssget '((0 . "INSERT")))) (progn (while (progn (and tol1 (while (progn (initget "Distance Plane-Axis Axes Help") (setq tol1 (cond ((getkword "\nSelect overkill mode [Distance/Plane-Axis/Axes/Help] : ")) ("Distance"))) (if (eq tol1 "Help") (not (alert (strcat "\nBOVERKILL tolerance mode." "\n" "\nThis command offers three types of mode for tolerance calculation that assumes two of the same " "blocks are considered a duplicate:" "\n" "\n1. Distance - This is the standard and most common type of tolerance calculation. Two blocks are " "considered duplicates if the distance between them are within the specified tolerance." "\n" "\n2. Plane-Axis - This mode calculates using one tolerance along any one of the " "XY, XZ or YZ planes, and another tolerance about the third axis of the chosen plane." "\nTwo blocks are considered a duplicate if the two tolerances are satisfactory." "\n" "\n3. Axes - This mode calculates using three different tolerances, one for each axis. Two blocks are " "considered duplicates if the distance between them are within the specified tolerance along all three axes." "\n" "\nAll plane and axis tolerance calculations are relative to the current UCS." ) ) ) ) ) ) ) (cond ( (member tol1 '("Distance" nil)) (initget "Mode") (setq tol1 (cond ((getdist "\nSpecify overkill tolerance or [Mode] <0.00001>: ")) (1e-5))) ) ( (eq tol1 "Plane-Axis") (initget "XY XZ YZ Mode") (if (not (eq (setq tol1 (cond ((getkword "\nSpecify plane to calculate tolerance [XY/XZ/YZ/Mode] : ")) ("XY"))) "Mode")) (setq mod tol1 tol1 (cond ((getdist (strcat "\nSpecify overkill tolerance along the " mod "-Plane <0.00001>: "))) (1e-5)) tol2 (cond ((getdist (strcat "\nSpecify overkill tolerance along the " (vl-string-trim " " (vl-string-translate mod " " "XYZ")) "-Axis <0.00001>: "))) (1e-5)) ) ) ) ( (eq tol1 "Axes") (initget "Mode") (if (not (eq (setq mod tol1 tol1 (cond ((getdist "\nSpecify overkill tolerance on X-Axis or [Mode] <0.00001>: ")) (1e-5)) ) "Mode" ) ) (setq tol2 (cond ((getdist "\nSpecify overkill tolerance on Y-Axis <0.00001>: ")) (1e-5)) tol3 (cond ((getdist "\nSpecify overkill tolerance on Z-Axis <0.00001>: ")) (1e-5)) ) ) ) ) (eq tol1 "Mode") ) ) (setq ss (mapcar '(lambda (x / enx) (list x (trans (trans (cdr (assoc 10 (setq enx (entget x)))) (cdr (assoc 210 enx)) 0) 0 1) (vla-get-effectivename (setq x (vlax-ename->vla-object x))) (list (vla-get-xeffectivescalefactor x) (vla-get-yeffectivescalefactor x) (vla-get-zeffectivescalefactor x) ) (cdr (assoc 210 enx)) ) ) (Boverkill:selset-to-list ss) ) ) (cond ( (eq mod "Axes") (setq dp (BlockOverkill:Axes ss (+ 1e-8 tol1) (+ 1e-8 tol2) (+ 1e-8 tol3)))) ( (member mod '("XY" "XZ" "YZ")) (setq dp (BlockOverkill:Plane-Axis ss mod (+ 1e-8 tol1) (+ 1e-8 tol2)))) ( (setq dp (BlockOverkill:Distance ss (+ 1e-8 tol1)))) ) (if dp (progn (initget "Delete Move") (if (eq (cond ((getkword (strcat "\n" (itoa (length dp)) " duplicates found. Delete or move to different layer? [Delete/Move] : "))) ("Delete") ) "Delete" ) (progn (foreach x dp (entdel (car x))) (princ (strcat "\n") (itoa (length dp)) " blocks deleted. Refer selected circles.") ) (progn (while (progn (setvar "errno" 0) (initget "Name Current") (setq ly (entsel "\nSpecify destination layer or [Name/Current] : ")) (cond ( (= (getvar "errno") 7) (princ "\nNothing selected.")) ( (member ly '("Current" nil)) (setq ly (cons 8 (getvar 'clayer))) (foreach x dp (entmod (subst ly (assoc 8 (setq enx (entget (car x)))) enx))) (not (princ (strcat "\n") (itoa (length dp)) " blocks moved to the current layer. Refer selected circles.")) ) ( (eq ly "Name") (while (progn (setq ly (getstring t "\nSpecify layer name : ")) (cond ( (eq ly "") (setq ly (cons 8 (getvar 'clayer))) (foreach x dp (entmod (subst ly (assoc 8 (setq enx (entget (car x)))) enx))) (not (princ (strcat "\n") (itoa (length dp)) " blocks moved to the layer \"" (cdr ly) "\". Refer selected circles.")) ) ( (not (Boverkill:ValidLayerName ly)) (princ "\nLayer cannot contain the following characters: < > / \\ \" : ; ? * | , = '") ) ( t (setq ly (cons 8 ly)) (foreach x dp (entmod (subst ly (assoc 8 (setq enx (entget (car x)))) enx))) (not (princ (strcat "\n") (itoa (length dp)) " blocks moved to the layer \"" (cdr ly) "\". Refer selected circles.")) ) ) ) ) ) ( t (setq ly (assoc 8 (entget (car ly)))) (foreach x dp (entmod (subst ly (assoc 8 (setq enx (entget (car x)))) enx))) (not (princ (strcat "\n") (itoa (length dp)) " blocks moved to the layer \"" (cdr ly) "\". Refer selected circles.")) ) ) ) ) ) ) (setq del (ssadd)) (foreach x dp (setq del (ssadd (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 8 (cond ((nth 0 (BlockOverkill:Settings))) ((getvar 'clayer)))) (cons 10 (trans (trans (cadr x) 1 0) 0 (nth 4 x))) (cons 40 (cond ((nth 1 (BlockOverkill:Settings))) (100))) (cons 62 (cond ((nth 2 (BlockOverkill:Settings))) (256))) (cons 210 (nth 4 x)) ) ) del ) ) ) (sssetfirst nil del) ) (princ "\nNo duplicates found.") ) ) ) (setvar "PICKADD" pck) (if (not activeundo) (vla-EndUndoMark adoc)) (princ) ) (defun BlockOverkill:Distance (ss tol / rtn) (foreach x ss (vl-some (function (lambda (y) (if (and (equal (cadr x) (cadr y) tol) (eq (caddr x) (caddr y)) (equal (cadddr x) (cadddr y) tol) ) (setq rtn (cons x rtn)) ) ) ) (setq ss (cdr ss)) ) ) rtn ) (defun BlockOverkill:Axes (ss tolx toly tolz / rtn) (foreach x ss (vl-some (function (lambda (y) (if (and (equal (car (cadr x)) (car (cadr y)) tolx) (equal (cadr (cadr x)) (cadr (cadr y)) toly) (equal (caddr (cadr x)) (caddr (cadr y)) tolz) (eq (caddr x) (caddr y)) (equal (cadddr x) (cadddr y) (/ (+ tolx toly tolz) 3.0)) ) (setq rtn (cons x rtn)) ) ) ) (setq ss (cdr ss)) ) ) rtn ) (defun BlockOverkill:Plane-Axis (ss mod tol1 tol2 / sst rtn) (cond ( (eq mod "XY") (setq sst (mapcar '(lambda (x) (append (list (car x) (list (car (cadr x)) (cadr (cadr x))) (caddr (cadr x)) ) (cddr x) ) ) ss ) ) ) ( (eq mod "XZ") (setq sst (mapcar '(lambda (x) (append (list (car x) (list (car (cadr x)) (caddr (cadr x))) (cadr (cadr x)) ) (cddr x) ) ) ss ) ) ) ( (eq mod "YZ") (setq sst (mapcar '(lambda (x) (append (list (car x) (list (cadr (cadr x)) (caddr (cadr x))) (car (cadr x)) ) (cddr x) ) ) ss ) ) ) ) (mapcar '(lambda (w x) (vl-some (function (lambda (y) (if (and (equal (cadr x) (cadr y) tol1) (equal (caddr x) (caddr y) tol2) (eq (cadddr x) (cadddr y)) (equal (nth 4 x) (nth 4 y) (/ (+ tol1 tol2) 2.0)) ) (setq rtn (cons w rtn)) ) ) ) (setq ss (cdr ss) sst (cdr sst)) ) ) ss sst ) rtn ) (vl-load-com) ;; Boverkill:selset-to-list --> Jonathan Handojo ;; Returns a list of entities from a selection set ;; ss - selection set (defun Boverkill:selset-to-list (selset / lst iter) (if selset (repeat (setq iter (sslength selset)) (setq lst (cons (ssname selset (setq iter (1- iter))) lst)) ) ) ) ;; Boverkill:ValidLayerName --> Jonathan Handojo ;; Checks whether a layer name is valid for new layer creation (defun Boverkill:ValidLayerName (str) (and (< 0 (strlen str) 255) (not (vl-some (function (lambda (a) (member a '(60 62 47 92 34 58 59 63 42 124 44 61 39)) ) ) (vl-string->list str) ) ) ) )