;;; --------------------------------------------------------------------------- ;;; BlockLocate.lsp ;;; code compiled by YZ August 2026 ;;; --------------------------------------------------------------------------- ;;; FIND EVERY INSERTION OF A BLOCK ;;; ;;; PURPOSE ;;; Answers "where are all the manholes?" on a drawing too big to see at once. ;;; Name a block, or pick one, and every insertion of it is found and shown. ;;; ;;; Three ways to look at the answer: ;;; ;;; Rays temporary lines from a point you pick out to every insertion, so ;;; the whole spread is visible in one glance ;;; Step zoom to each insertion in turn, pressing Enter to advance ;;; List a coordinate table on the text screen ;;; ;;; None of them change the drawing. The rays are temporary vectors that clear ;;; on the next redraw, and stepping only moves the view. ;;; ;;; WHY NOT JUST QSELECT ;;; QSELECT will select them, which tells you how many and puts grips on them - ;;; but on a site plan a mile across, grips you cannot see are no help. This is ;;; about finding out WHERE they are. ;;; ;;; XREFS ARE EXCLUDED ;;; An xref and a block are both INSERT entities, so telling them apart takes ;;; two tests: an xref's block table record carries a path in group 1, and a ;;; nested xref's name contains a pipe character. Both are checked, because ;;; either alone lets one through. ;;; ;;; Anonymous blocks - hatch patterns, dimensions and dynamic block variants, ;;; all named *U or *D followed by a number - are excluded too. They are not ;;; things anyone goes looking for. ;;; ;;; BLOCKLOCATE - find and show every insertion of a block ;;; --------------------------------------------------------------------------- ;;; --------------------------------------------------------------------------- ;;; THE BLOCK LIST ;;; ;;; Walks the block table once and returns the names worth offering: real blocks, ;;; no xrefs, no anonymous internals. ;;; --------------------------------------------------------------------------- (defun BlockLocate:Names ( / rec name out ) (setq rec (tblnext "block" t)) (while rec (setq name (cdr (assoc 2 rec))) (if (and name ;; group 1 holds an xref's path - a real block has none (null (cdr (assoc 1 rec))) ;; a nested xref carries the pipe separator (not (wcmatch name "*`|*")) ;; anonymous internals (not (wcmatch name "`**"))) (setq out (cons name out))) (setq rec (tblnext "block"))) (vl-sort out '<) ) ;;; Every insertion of one block name, as a list of insertion points. (defun BlockLocate:Points ( name / ss i out ) (if (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 2 name)))) (progn (setq i 0) (repeat (sslength ss) (setq out (cons (cdr (assoc 10 (entget (ssname ss i)))) out) i (1+ i))) (reverse out))) ) ;;; Ask for a block, by name or by picking one. Returns the name, or nil. (defun BlockLocate:Ask ( / names opt sel dat name rec ) (setq names (BlockLocate:Names)) (if (null names) (progn (princ "\nThis drawing contains no blocks.") nil) (progn (initget "Pick List Name") (setq opt (getkword "\nChoose the block by [Pick one/List names/type a Name] : ")) (if (null opt) (setq opt "Pick")) (if (= opt "List") (progn (textscr) (princ (strcat "\n\n " (itoa (length names)) " block(s) in this drawing\n")) (foreach n names (princ (strcat "\n " n))) (princ "\n") (graphscr) (setq opt "Name"))) (cond ((= opt "Name") (setq name (strcase (getstring "\nBlock name: "))) (cond ((= name "") nil) ((member name names) name) ;; A name that exists but was filtered out deserves a ;; different message from one that does not exist at all. ((tblsearch "block" name) (princ "\nThat is an xref or an internal block - not something to locate.") nil) (t (princ "\nNo block of that name in this drawing.") nil))) (t ;; Loop rather than recurse: the original called itself again on ;; every bad pick, which stacks up with no way back out. (setq name nil) (while (null name) (setq sel (entsel "\nPick an example of the block : ")) (cond ((null sel) (setq name 'quit)) ((/= "INSERT" (cdr (assoc 0 (setq dat (entget (car sel)))))) (princ "\nThat is not a block.")) (t (setq name (cdr (assoc 2 dat)) rec (tblsearch "block" name)) (if (or (cdr (assoc 1 rec)) (wcmatch name "*`|*")) (progn (princ "\nThat is an xref - xrefs are not located.") (setq name nil)))))) (if (eq name 'quit) nil name)) ) ) ) ) ;;; --------------------------------------------------------------------------- ;;; MAIN COMMAND ;;; --------------------------------------------------------------------------- (defun c:BLOCKLOCATE ( / *error* vars vals name pts n mode hub i p minx maxx miny maxy ) (setq vars '("CMDECHO" "OSMODE" "BLIPMODE") vals (mapcar 'getvar vars)) (defun BlockLocate:Restore ( ) (mapcar 'setvar vars vals) (princ) ) ;; No undo group and no (command) in the error path here: this routine ;; changes nothing, so there is nothing to roll back and nothing to close. (defun *error* ( msg ) (BlockLocate:Restore) (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*"))) (princ (strcat "\n** BLOCKLOCATE error: " msg " **"))) (princ) ) (setvar "CMDECHO" 0) (if (null (setq name (BlockLocate:Ask))) (princ "\nNothing to locate.") (progn (setq pts (BlockLocate:Points name) n (length pts)) (if (zerop n) (princ (strcat "\nBlock " name " is defined but never inserted in this drawing.")) (progn ;; Extents of the insertions, which is often the answer on ;; its own - it says whether they are clustered or scattered. (setq minx (apply 'min (mapcar 'car pts)) maxx (apply 'max (mapcar 'car pts)) miny (apply 'min (mapcar 'cadr pts)) maxy (apply 'max (mapcar 'cadr pts))) (princ (strcat "\n" (itoa n) " insertion(s) of " name ", spread over " (rtos (- maxx minx) 2 2) " by " (rtos (- maxy miny) 2 2) ".")) (initget "Rays Step List") (setq mode (getkword "\nShow them by [Rays/Step through/List] : ")) (if (null mode) (setq mode "Rays")) (setvar "BLIPMODE" 0) (cond ;; --- rays from a hub --------------------------------- ((= mode "Rays") (setvar "OSMODE" 0) (if (setq hub (getpoint "\nPick a clear point to draw from: ")) (progn ;; GRDRAW vectors are temporary - they survive ;; until the next regen, which is what makes this ;; safe to run on a drawing you are not editing. (foreach p pts (grdraw hub p 40)) (princ (strcat "\n" (itoa n) " ray(s) drawn. They clear on the next redraw."))))) ;; --- step through ------------------------------------ ((= mode "Step") (setq i 0) (foreach p pts (setq i (1+ i)) (command "_.ZOOM" "_C" p (getvar "VIEWSIZE")) (grdraw (polar p (* pi 0.25) (/ (getvar "VIEWSIZE") 20.0)) (polar p (* pi 1.25) (/ (getvar "VIEWSIZE") 20.0)) 40) (grdraw (polar p (* pi 0.75) (/ (getvar "VIEWSIZE") 20.0)) (polar p (* pi 1.75) (/ (getvar "VIEWSIZE") 20.0)) 40) (princ (strcat "\n" (itoa i) " of " (itoa n) " at " (rtos (car p) 2 3) ", " (rtos (cadr p) 2 3) " - Enter for next, Escape to stop")) (getstring))) ;; --- coordinate list --------------------------------- ((= mode "List") (textscr) (princ (strcat "\n\n " (itoa n) " insertion(s) of " name "\n")) (setq i 0) (foreach p pts (setq i (1+ i)) (princ (strcat "\n " (itoa i) " " (rtos (car p) 2 4) ", " (rtos (cadr p) 2 4)))) (princ "\n")) ) ) ) ) ) (BlockLocate:Restore) (princ) ) (princ)