Leaderboard

Bit late to the party but try this. See the header for changes I've made. (vl-load-com) ;; ;; Replace multiple instances of selected blocks (can be different) with selected block ;; Size and Rotation will be taken from original block and original will be deleted ;; Required subroutines: AT:GetSel ;; Alan J. Thompson, 2010.09.02 ;; Found at: http://www.cadtutor.net/forum/showthread.php?48458-Replace-Selected-Block-Or-Blocks-With-Another-Block ;; ;; EDIT by 3dwannab, 2018.04.09 - Added redraw to old block selection, Error handling for redraw and sssetfirst newly created blocks. ;; EDIT by 3dwannab, 2024.08.15 - Removed original selection from the new selection set and output block name to commandline. ;; EDIT by 3dwannab, 2024.11.28 - Give the user the ability to replace the same blocks by name as the ones selected. Option Yes/No. ;; - Option to choose whether you want to match properties or not. Option Yes/No. ;; - Added undo handling. ;; - Changed the redraw to a regen to correctly display the new selection of blocks. ;; ;; TO DO LIST ;; N/A ;; (defun c:BKReplace (/ *error* acDoc ansMatchProps ansReplaceAll blkNew blkNewObj def e f lst ssReplaced ssSel ssVla var_cmdecho var_osmode var_selectsimilarmode) (defun *error* (errmsg) (and acDoc (vla-EndUndoMark acDoc)) (and errmsg (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*")) (princ (strcat "\n<< Error: " errmsg " >>\n")) ) (command "_.regen") (setvar 'cmdecho var_cmdecho) (setvar 'osmode var_osmode) (setvar 'selectsimilarmode var_selectsimilarmode) ) ;; Start the undo mark here (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc)) ;; Get any system variables here (setq var_cmdecho (getvar "cmdecho")) (setq var_osmode (getvar "osmode")) (setq var_selectsimilarmode (getvar 'selectsimilarmode)) (setvar 'cmdecho 0) (setvar 'osmode 0) (if (and (AT:GetSel entsel "\nSelect NEW block: " (lambda (blkOriginal / e) (if (and (eq "INSERT" (cdr (assoc 0 (setq e (entget (car blkOriginal)))))) (/= 4 (logand (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 e))))) 4)) (/= 4 (logand (cdr (assoc 70 (entget (tblobjname "LAYER" (cdr (assoc 8 e)))))) 4)) ) (setq blkNewObj (vlax-ename->vla-object (car blkOriginal))) ) ) ) (not (redraw (vlax-vla-object->ename blkNewObj) 3)) ) (progn ;; initget from LeeMac help pages (initget "No Yes") (setq ansReplaceAll (cond ((getkword (strcat "\nReplace all the same blocks as the one you select now ? [Yes/No] <" (setq ansReplaceAll (cond (ansReplaceAll) ("Yes"))) ">: " ) ) ) (ansReplaceAll) ) ) ;; If No to replace blocks only replace the selection (if (= ansReplaceAll "No") (progn (princ "\nSelect OLD blocks to be replaced: ") (setq ssReplaced (ssget "_:L" '((0 . "INSERT")))) ) ;; If yes, replace the same blocks as the one you select (progn ; Code by Lee Mac http://www.cadtutor.net/forum/showthread.php?92638-Simple-fix-%28LISP-noob%29-Syntax-problem&p=633824&viewfull=1#post633824 ;; Iterate over the block table and compile a list of xref blocks to exclude (while (setq def (tblnext "block" (not def))) (if (= 4 (logand 4 (cdr (assoc 70 def)))) (setq lst (vl-list* "," (cdr (assoc 2 def)) lst)) ) ) ;; Attempt to retrieve a selection of blocks (but not xrefs) (setq ssReplaced (ssget (cons '(0 . "INSERT") (if lst (vl-list* '(-4 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '((-4 . "NOT>"))))))) ;; Set selectsimilarmode to use the name of an object. (setvar 'selectsimilarmode 128) ;; If ss1 one is valid then do this (if ssReplaced (progn (vl-cmdf "_.selectsimilar" ssReplaced "") (setq ssReplaced nil) ;; Reset the selection set (setq ssReplaced (ssget)) ;; Create a new selection set for to zoom and reselect as the zoom objects will do this ) (princ "\n: ------------------------------\n\t\t*** Nothing selected ***\n: ------------------------------\n") ) ) ) (setq f (not (vla-startundomark (cond (acDoc) ((setq acDoc (vla-get-activedocument (vlax-get-acad-object)))) ) ) ) ) ;; initget from LeeMac help pages (initget "No Yes") (setq ansMatchProps (cond ((getkword (strcat "\nMatch these properties? Insertionpoint, Rotation, XEffectiveScaleFactor, YEffectiveScaleFactor & ZEffectiveScaleFactor\nNo only matches the Insertion Point and Rotation[Yes/No] <" (setq ansMatchProps (cond (ansMatchProps) ("Yes"))) ">: " ) ) ) (ansMatchProps) ) ) ; Set ssSel to a null selection set: (setq ssSel (ssadd)) (vlax-for blkOriginal (setq ssVla (vla-get-activeselectionset acDoc)) ;; Check if old block is not part of the new selection (if (not (equal (vlax-vla-object->ename blkNewObj) (vlax-vla-object->ename blkOriginal))) (progn (setq blkNew (vla-copy blkNewObj)) (cond ((= "Yes" ansMatchProps) (mapcar (function (lambda (p) (vl-catch-all-apply (function vlax-put-property) (list blkNew p (vlax-get-property blkOriginal p)) ) ) ) '(Insertionpoint Rotation XEffectiveScaleFactor YEffectiveScaleFactor ZEffectiveScaleFactor) ) ) ((= "No" ansMatchProps) ;; Only match the insertion point (mapcar (function (lambda (p) (vl-catch-all-apply (function vlax-put-property) (list blkNew p (vlax-get-property blkOriginal p)) ) ) ) '(Insertionpoint Rotation) ) ) ) ; The following command adds the blkNew entity to the selection set referenced by ss2: (ssadd (vlax-vla-object->ename blkNew) ssSel) (vla-delete blkOriginal) ) ) ) ; Select ssSel (sssetfirst nil ssSel) (redraw (vlax-vla-object->ename blkNewObj) 4) (vla-delete ssVla) (princ (strcat "\n'" (vla-get-effectivename blkNewObj) "' has replaced " (itoa (sslength ssReplaced)) (if (> (sslength ssReplaced) 1) " blocks" " block"))) ) ) (vla-EndUndoMark acDoc) (*error* nil) (princ) ) (defun AT:GetSel (meth msg fnc / ent good) ;; meth - selection method (entsel, nentsel, nentselp) ;; msg - message to display (nil for default) ;; fnc - optional function to apply to selected object ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (blkOriginal) (eq (cdr (assoc 0 (entget (car blkOriginal)))) "ARC"))) ;; Alan J. Thompson, 05.25.10 (setvar 'errno 0) (while (not good) (setq ent (meth (cond (msg) ("\nSelect OLD blocks to be replaced: ") ) ) ) (cond ((vl-consp ent) (setq good (cond ((or (not fnc) (fnc ent)) ent) ((prompt "\nInvalid object!")) ) ) ) ((eq (type ent) 'STR) (setq good ent)) ((setq good (eq 52 (getvar 'errno))) nil) ((eq 7 (getvar 'errno)) (setq good (prompt "\nMissed, try again."))) ) ) ) (princ "\nBK_Replace.lsp loaded...") (princ) ; (c:BKReplace) ;; Unblock for testing

Edit: Wasn't working.... See what you are doing pkenewell, but the colour codes might need to remove the paired { } - could be a situation where formats overlap (colour, underline, italic.... ) which for a dimension, leader etc is a slim chance from a draughtsman who maybe should be shot, but still a slim chance. The wrong closing } will close the wrong format. 'Wasn't working' was a modified Lee Mac Un-format for just the colour codes but the paired { } wasn't quite working right, Could do a modified StripMText to take out the interface and just colours.. but a lot more code in there Edit again... for reference.... might just work... and the irony of reference - I have lost the reference where I got this from. (defun c:NoColMT ( / ) ; No Colour MText (NoForMT (strcase (getstring "\nEnter Code (C, T, H, W, Q)"))) (princ) ) (defun NoForMt ( MyCode / MyEnt ed MyString SwapSlashes StrPos ColonPos ColourCode) ; C, T, H, W, Q ;;Slight discrepancy, opening '{' is retained at first formatting point (setq MyEnt (car (entsel))) ;;Select single text entity (setq ed (entget MyEnt)) ;;Entity Definition (setq MyString (cdr (assoc 1 ed))) ;;Extract Text (setq SwapSlashes "ADDINGINBLACKSLASH") (while (wcmatch MyString "*\\\\*" )(setq MyString (vl-string-subst SwapSlashes "\\\\" MyString) )) ;;hide \\\\ (if (and (wcmatch MyString (strcat "*{*`\\" MyCode "*}*")) (= (cdr (assoc 0 ed)) "MTEXT") ) (progn (while (wcmatch MyString (strcat "*{*`\\" MyCode "*}*")) (setq StrPos (vl-string-search (strcat "\\" MyCode) MyString ) ) (setq ColonPos (+ (vl-string-search ";" MyString (+ StrPos 3)) 2)) (setq ColourCode (substr MyString (+ StrPos 1) (- ColonPos (+ StrPos 1)) ) ) (setq MyString (vl-string-subst "" ColourCode MyString) ) ) ; end while (setq ed (subst (cons 1 MyString) (assoc 1 ed) ed )) ;; text String <~250 characters (entmod ed) ;; Modify & update entity ) ; end progn ) ; end if (while (wcmatch MyString (strcat "*" SwapSlashes "*") )(setq MyString (vl-string-subst "\\\\" SwapSlashes MyString) )) )

@StevJ, it's sort of beyond the scope of this program. I wrote it to learn how to make programs with DCLs' more or less but has been very useful today at work. You can change the height of that programs UI too. Open the lisp and search for the height property for that listbox I'd say and change that to your needs. The DCL code is hardcoded into the .lsp file with that one. Something I didn't bother to do with this. (Lazy). I've fixed the issue of the blocks and layers not getting selected or highlighted with the help from @pkenewell for that, see post here. Attached is the fixed version. REVISION HISTORY: 2024.11.17 - v1.0 - First release 2024.11.19 - v1.01 - Layers and blocks can now be renamed without the loss of highlighting or selection issues present in the previous version. Thanks pkenewell on CAD Tutors. - Better handling of the buttons in the UI. Disabling / enabling / focusing them where required. 3dwannab_Rename_Blocks_and_Layers.lsp 3dwannab_Rename_Blocks_and_Layers.dcl

@3dwannab Very nice! Didn't know that the dynamic prompts caused that problem. Learn something new every day!

Wrote it, so might as well post it: (defun c:mtt ( / *error* _StartUndo _EndUndo _GetTextInsertion _PutTextInsertion Props doc entity object ss ) (vl-load-com) ;; © Lee Mac 2010 (setq Props '( Alignment AttachmentPoint BackgroundFill Backward DrawingDirection Height Layer LineSpacingDistance LineSpacingFactor LineSpacingStyle Linetype LinetypeScale Lineweight ObliqueAngle Rotation ScaleFactor StyleName TextString Thickness UpsideDown Width ) ) (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (defun *error* ( msg ) (if doc (_EndUndo doc)) (if mutt (setvar 'NOMUTT mutt)) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **"))) (princ) ) (defun _StartUndo ( doc ) (_EndUndo doc) (vla-StartUndoMark doc) ) (defun _EndUndo ( doc ) (if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndoMark doc) ) ) (defun _GetTextInsertion ( object ) (vlax-get-property object (if (or (eq "AcDbMText" (vla-get-ObjectName object)) (vl-position (vla-get-Alignment object) (list acAlignmentLeft acAlignmentFit acAlignmentAligned)) ) 'InsertionPoint 'TextAlignmentPoint ) ) ) (defun _PutTextInsertion ( object point ) (vlax-put-property object (if (or (eq "AcDbMText" (vla-get-ObjectName object)) (vl-position (vla-get-Alignment object) (list acAlignmentLeft acAlignmentFit acAlignmentAligned)) ) 'InsertionPoint 'TextAlignmentPoint ) point ) ) (if (and (setq entity (LM:Selectif (lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "TEXT,MTEXT,ATTRIB,ATTDEF") ) nentsel "\nSelect Source Object: " ) ) (progn (setq mutt (getvar 'NOMUTT)) (setvar 'NOMUTT 1) (princ (strcat "\nSelect Destination " (cdr (assoc 0 (entget entity))) " objects: ")) (setq object (vlax-ename->vla-object entity) ss (ssget "_:L" (list (assoc 0 (entget entity)) ) ) ) (setvar 'NOMUTT mutt) ss ) ) ( (lambda ( i values / entity obj ) (_StartUndo doc) (while (setq entity (ssname ss (setq i (1+ i)))) (setq obj (vlax-ename->vla-object entity)) (mapcar (function (lambda ( prop value / err ) (if (vl-catch-all-error-p (setq err (vl-catch-all-apply (function (lambda nil (if (and (vlax-property-available-p obj prop t) value) (if (vl-position prop '(Alignment AttachmentPoint)) ( (lambda ( insertion ) (vlax-put-property obj prop value) (_PutTextInsertion obj insertion) ) (_GetTextInsertion obj) ) (vlax-put-property obj prop value) ) ) ) ) ) ) ) (princ (strcat "\n** Error Applying Property: " (vl-princ-to-string Prop) ": " (vl-catch-all-error-message err) " **" ) ) ) ) ) Props Values ) ) (_EndUndo doc) ) -1 (mapcar (function (lambda ( prop ) (if (vlax-property-available-p object prop) (vlax-get-property object prop) ) ) ) Props ) ) ) (princ) ) ;;---------------------=={ Select if }==----------------------;; ;; ;; ;; Continuous selection prompts until the predicate function ;; ;; foo is validated ;; ;;------------------------------------------------------------;; ;; Author: Lee McDonnell, 2010 ;; ;; ;; ;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; ;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; foo - optional predicate function taking ename argument ;; ;; fun - selection function to invoke ;; ;; str - prompt string ;; ;;------------------------------------------------------------;; ;; Returns: selected entity ename if successful, else nil ;; ;;------------------------------------------------------------;; (defun LM:Selectif ( foo fun str / e ) ;; © Lee Mac 2010 (while (progn (setq e (car (fun str))) (cond ( (eq 'ENAME (type e)) (if (and foo (not (foo e))) (princ "\n** Invalid Object Selected **")) ) ) ) ) e ) Check/Edit list of properties at the top of the code to match Lee