Leaderboard

Okay, I got something. It copy/pastes: - color - linetype - Transparency of an object that you select. And sets those properties to a new layer that you type (getstring). If there's anything more the script should do, then tell me. Command: CNLIP (for: Create New Layer Identical Properties) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; https://forum.bricsys.com/discussion/28719/how-to-put-transparency-to-an-objekt-in-bricscad-16 ; Transparency: ; 0 ; Transparency ByLayer. ; (lsh 1 24) => 16777216 ; Transparency ByBlock. ; (lsh 2 24) => 33554432 ; Transparency 100%; Saturation 0%. ; (+ (lsh 2 24) 255) => 33554687 ; Transparency 0%; Saturation 100%. ; (_Sys_Transparency_Num_To_Perc 33554661) => 0.1 ; (_Sys_Transparency_Num_To_Perc (cdr (assoc 440 (entget (car (entsel)))))) (defun _Sys_Transparency_Num_To_Perc (num) (* 0.01 (fix (/ (- 33554687 num) 2.55))) ) ; (_Sys_Transparency_Perc_To_Num 0.1) => 33554661 (defun _Sys_Transparency_Perc_To_Num (perc) (fix (- 33554687 (* perc 255))) ) ; (TransparencyPut (car (entsel)) "80") ; (TransparencyPut (car (entsel)) "ByLayer") ; (TransparencyPut (car (entsel)) "ByBlock") (defun TransparencyPut (enme str) (vle-entmod 440 enme (cond ((= "BYLAYER" (strcase str)) 0 ) ((= "BYBLOCK" (strcase str)) 16777216 ) (T (_Sys_Transparency_Perc_To_Num (* 0.01 (atoi str))) ) ) ) ) ; (TransparencyGet (car (entsel))) (defun TransparencyGet (enme / num) ;;(setq num (vle-entget 440 enme)) (setq num (cdr (assoc 440 (entget enme)))) ;;(princ num) (cond ((not num) "BYLAYER" ) ((zerop num) "BYLAYER" ) ((= 16777216 num) "BYBLOCK" ) (T (rtos (* 100 (_Sys_Transparency_Num_To_Perc num)) 2 0) ) ) ) ;; Test TransparencyGet (defun c:gtra ( / ) (TransparencyGet (car (entsel))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (vl-load-com) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; https://www.lee-mac.com/colourconversion.html ;; RGB -> True - Lee Mac ;; Args: r,g,b - [int] Red, Green, Blue values (defun LM:RGB->True ( r g b ) (logior (lsh (fix r) 16) (lsh (fix g) 8) (fix b)) ) ;; True -> RGB - Lee Mac ;; Args: c - [int] True Colour (defun LM:True->RGB ( c ) (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CREATE LAYER with color / also true color ;; transparency. ;; Taken from Steven P, I presume from a Lee Mac function. ;; https://www.cadtutor.net/forum/topic/85796-select-all-layer-turn-to-color-252/#findComment-640849 (defun LM:setlayertransparency ( lay trn / ent ) (defun LM:trans->dxf ( x ) (logior (fix (* 2.55 (- 100 x))) 33554432) ) (if (setq ent (tblobjname "layer" lay)) (progn (regapp "accmtransparency") (entmod (append (entget ent) (list (list -3 (list "accmtransparency" (cons 1071 (LM:trans->dxf trn)) ) ; end list ) ; end list ))) ; end entmod ) ; end progn ) ; end if ) ; end defun ;; (LM:setlayertransparency Layname (atoi xxx) ) ;; test, create earth cable layer (defun c:test_cl ( / ) (_create_new_layer_ "mynewlayer3" ;;name '(178 254 1) ;;color (yellowy green) "Center" ;;ltype 1 ;;plot ) ;; set to 70% transparency (LM:setlayertransparency "mynewlayer3" 70 ) (_create_new_layer_ "mynewlayer4" ;;name 15 ;;color "continuous" ;;ltype 1 ;;plot ) ) (defun _create_new_layer_ (lName color ltype plot / _rgb lt) (defun _rgb (l) (+ (lsh (fix (car l)) 16) (lsh (fix (cadr l)) 8) (fix (caddr l)))) (cond ((not (tblsearch "layer" lName)) (entmakex (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") '(70 . 0) (cons 2 lName) (if color (if (listp color) ;; see if color is a list of RGB (cons 420 (_rgb color)) (cons 62 color) ) ;; else, default white (cons 62 0) ) (cons 6 (if ltype (if (tblsearch "ltype" ltype) ltype "continuous" ) "continuous" ) ) (cons 290 plot) ;;1 = plottable 0 = not=plottable ) ) ) ((tblobjname "layer" lName)) ) ) ;; (_create_new_layer "NewLayerName" '(69 69 69) "3Dash2" 1) ;; true color, some dark grey ;; (_create_new_layer "NewLayerName2" 169 "3Dash2" 1) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; create a new layer by copying all properties from an existing object. ;; such as color (index color, true color, color books), line weight, line type, and transparency. ;; Create New Layer Identical Properties (defun c:cnlip ( / src lName color ltype transp) (setq src (car (entsel "\nSelect source object: "))) (setq color (if (or (assoc 420 (entget src)) (assoc 62 (entget src))) (if (assoc 420 (entget src)) (LM:True->RGB (cdr (assoc 420 (entget src)))) (cdr (assoc 62 (entget src))) ) ;; else ByLayer nil ) ) ;; Color. Must return: ;; - nil => ByLayer ;; - a integer: 0 to 255. 0 = ByBlock; 1=red, 2=yellow, ... ;; - RGB list of three 0-255 (princ "\nColor: ") (princ Color) ;;(princ " - ") ;;(princ (LM:True->RGB Color)) (setq ltype (if (assoc 6 (entget src)) (cdr (assoc 6 (entget src))) ;; else "continuous" ) ) (princ "\n\Linetype: ") (princ ltype) (setq lName (getstring "\nName of the new layer: ")) (_create_new_layer_ lName color ltype 1 ) ;; Transparency (setq transp (TransparencyGet src)) (if (atoi transp) (LM:setlayertransparency lName (atoi transp)) ) (princ "\nLayer created: ") (princ lName) (princ) )

Another quick one for fun. It defaults to a nearest snap. (defun c:foo (/ fz lyr p1 p2 s) ;; Adjust this value for your needs (setq fz 0.1) (while (and (or p1 (setq p1 (getpoint "\nSpecify start point: "))) (setq p2 (getpoint p1 "\nSpecify next point: ")) ) (and (not lyr) (setq s (ssget "_C" (mapcar '- p1 (list fz fz fz)) (mapcar '+ p1 (list fz fz fz)) '((0 . "LINE"))) ) ;; Take this line out if you don't want to use closest to snap (setq p1 (vlax-curve-getclosestpointto (ssname s 0) p1)) (setq lyr (assoc 8 (entget (ssname s 0)))) ) (if lyr (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) lyr)) (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2))) ) (setq p1 p2) ) (princ) )

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