jim78b Posted November 25, 2019 Share Posted November 25, 2019 hello i have this lisp that retain of a block linetype and color and put all to layer 0, i need even to retain lineweight please ;; BN0.lsp [command name the same] ;; = change all Block Entities [other than on Layer Defpoints] in selected Blocks' ;; definitions, including in any Nested Blocks, to Layer 0 with Color & Linetype ;; overrides from entity's source layer properties [if not otherwise overridden] ;; Kent Cooper, last edited 4 November 2014 (vl-load-com) (defun C:BN0 (/ *error* nametolist doc blkss inc blokobj blkname blknames ent edata ldata) (defun *error* (errmsg) (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break")) (princ (strcat "\nError: " errmsg)) ); if (vla-endundomark doc) (princ) ); defun - *error* (defun nametolist (blk / blkobj blkname); get Block name and put it into list of names (if (= (logand (cdr (assoc 70 (entget blk))) 4) 0) ; not an Xref (progn (setq blkobj (vlax-ename->vla-object blk) blkname (vlax-get-property blkobj (if (vlax-property-available-p blkobj 'EffectiveName) 'EffectiveName 'Name) ; to work with older versions that don't have dynamic Blocks ); ...get-property & blkname ); setq (if (not (member blkname blknames)); name not already in list (setq blknames (append blknames (list blkname))); then -- add to end of list ); if ); progn ); if ); defun -- nametolist (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc); = Undo Begin (if (setq blkss (ssget '((0 . "INSERT")))); User selection of any number of Blocks/Minserts/Xrefs (progn; then (repeat (setq inc (sslength blkss)); list of Block names from top-level selection (nametolist (ssname blkss (setq inc (1- inc)))) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [this way instead of via (repeat) or (foreach), so it can add Nested Blocks' names to list] (setq ent (tblobjname "block" blk)); Block definition as entity (if (= (logand (cdr (assoc 70 (entget ent))) 4) 0) ; not an Xref (while (setq ent (entnext ent)); then -- proceed through sub-entities in definition (setq edata (entget ent)) (if (member '(0 . "INSERT") edata) (nametolist ent)); if nested Block, add name to end of list (if (not (member '(8 . "Defpoints") edata)); process all entities NOT on Layer Defpoints (progn ; then (setq ldata (entget (tblobjname "layer" (cdr (assoc 8 edata))))); entity's Layer's properties (if (or ; [no Color override] (not (assoc 62 edata)); Bylayer (member '(62 . 0) edata); Byblock ); or (setq edata (append edata (list (assoc 62 ldata)))); then -- assign Layer's color ); if (if (and (or ; [no Linetype override] (not (assoc 6 edata)); Bylayer (member '(6 . "ByBlock") edata) ); or (not (member '(6 . "Continuous") ldata)) ; don't override ByLayer/ByBlock with Layer's linetype if Continuous ); and (setq edata (append edata (list (assoc 6 ldata)))); then -- assign Layer's linetype ); if (setq edata (subst '(8 . "0") (assoc 8 edata) edata)); to Layer 0 (entmod edata) ); progn -- then ); if -- not on Defpoints ); while -- sub-entities ); if (setq blknames (cdr blknames)); take first Block name off list ); while (command "_.regen") ); progn (prompt "\nNo Block(s) selected."); else ); if [user selection] (vla-endundomark doc); = Undo End (princ) ); defun (prompt "\nType BENL0CL to change all selected Blocks' Entities to Layer 0 retaining their Layers' color/linetype.") Quote Link to comment Share on other sites More sharing options...
Emmanuel Delay Posted November 25, 2019 Share Posted November 25, 2019 (edited) Lineweight is 370 So I did the same thing as 6 (linetype) for 370. Skipping ByLayer , which means it doesn't have a 370 (but byBlock or default is not a problem, I think). Lines 73->77 See if it does what you need. Try testing it for difficult cases, put in a few byLayer, byBlock, default, ... ;; BN0.lsp [command name the same] ;; = change all Block Entities [other than on Layer Defpoints] in selected Blocks' ;; definitions, including in any Nested Blocks, to Layer 0 with Color & Linetype ;; overrides from entity's source layer properties [if not otherwise overridden] ;; Kent Cooper, last edited 4 November 2014 (vl-load-com) (defun C:BN0 (/ *error* nametolist doc blkss inc blokobj blkname blknames ent edata ldata) (defun *error* (errmsg) (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break")) (princ (strcat "\nError: " errmsg)) ); if (vla-endundomark doc) (princ) ); defun - *error* (defun nametolist (blk / blkobj blkname); get Block name and put it into list of names (if (= (logand (cdr (assoc 70 (entget blk))) 4) 0) ; not an Xref (progn (setq blkobj (vlax-ename->vla-object blk) blkname (vlax-get-property blkobj (if (vlax-property-available-p blkobj 'EffectiveName) 'EffectiveName 'Name) ; to work with older versions that don't have dynamic Blocks ); ...get-property & blkname ); setq (if (not (member blkname blknames)); name not already in list (setq blknames (append blknames (list blkname))); then -- add to end of list ); if ); progn ); if ); defun -- nametolist (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc); = Undo Begin (if (setq blkss (ssget '((0 . "INSERT")))); User selection of any number of Blocks/Minserts/Xrefs (progn; then (repeat (setq inc (sslength blkss)); list of Block names from top-level selection (nametolist (ssname blkss (setq inc (1- inc)))) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [this way instead of via (repeat) or (foreach), so it can add Nested Blocks' names to list] (setq ent (tblobjname "block" blk)); Block definition as entity (if (= (logand (cdr (assoc 70 (entget ent))) 4) 0) ; not an Xref (while (setq ent (entnext ent)); then -- proceed through sub-entities in definition (setq edata (entget ent)) (if (member '(0 . "INSERT") edata) (nametolist ent)); if nested Block, add name to end of list (if (not (member '(8 . "Defpoints") edata)); process all entities NOT on Layer Defpoints (progn ; then (setq ldata (entget (tblobjname "layer" (cdr (assoc 8 edata))))); entity's Layer's properties (if (or ; [no Color override] (not (assoc 62 edata)); Bylayer (member '(62 . 0) edata); Byblock ); or (setq edata (append edata (list (assoc 62 ldata)))); then -- assign Layer's color ); if (if (and (or ; [no Linetype override] (not (assoc 6 edata)); Bylayer (member '(6 . "ByBlock") edata) ); or (not (member '(6 . "Continuous") ldata)) ; don't override ByLayer/ByBlock with Layer's linetype if Continuous ); and (setq edata (append edata (list (assoc 6 ldata)))); then -- assign Layer's linetype ); if (if (not (assoc 370 edata)); Bylayer; [no Linetype override] ;; don't override ByLayer (setq edata (append edata (list (assoc 370 ldata)))); then -- assign Layer's lineweight ); if (setq edata (subst '(8 . "0") (assoc 8 edata) edata)); to Layer 0 (entmod edata) ); progn -- then ); if -- not on Defpoints ); while -- sub-entities ); if (setq blknames (cdr blknames)); take first Block name off list ); while (command "_.regen") ); progn (prompt "\nNo Block(s) selected."); else ); if [user selection] (vla-endundomark doc); = Undo End (princ) ); defun (prompt "\nType BN0 to change all selected Blocks' Entities to Layer 0 retaining their Layers' color/linetype/lineweight.") Edited November 25, 2019 by Emmanuel Delay 1 Quote Link to comment Share on other sites More sharing options...
jim78b Posted November 25, 2019 Author Share Posted November 25, 2019 thanks perfect! 1 Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.