Good morning to everyone
I have found this lisp
Which creates in Autocad
A new layer
It gives it new colour.
It adjusts the transparency
It adjusts the Plottable to yes or no
It chooses Lineweight
It chooses Linetype
And at the end it mekes it current
Ok Finish
Can someone modify it for me so that I can change (modify) the above characteristics in one or several layers that are selected on the Αutocad screen by pointing with the cursor to an object (entity) and passing the layer to it (extract the layer).
Thank you all in advance.
; QuickLayer - Grrr
; Credits to Lee Mac
(defun C:NL ( / layers tmpL *error* dcl des dch dcf lnm col rtn )
(setq layers ((lambda ( / d L ) (while (setq d (tblnext "LAYER" (not d))) (setq L (cons (cdr (assoc 2 d)) L))) L)))
(setq tmpL
'( (87 114 105 116 116 101 110 32 98 121 32 71 114 114 114)
(_Transparency ( k def / i L )
(repeat (setq i 91) (setq L (cons (itoa (setq i (1- i))) L)))
(start_list k) (mapcar 'add_list L) (end_list)
(set_tile k (itoa (vl-position def L)))
L
)
(_Plottable ( k def / L ) (start_list k) (mapcar 'add_list (setq L '("Yes" "No"))) (end_list) L )
(_Lineweight ( k def / r )
(start_list k)
(mapcar 'add_list
(mapcar
'(lambda (x)
(
(lambda (xx / tmp)
(cond
( (= 3 (length (setq tmp (vl-string->list xx))))
(apply '(lambda (a b c) (vl-list->string (list a 46 b c))) tmp)
)
( (= 11 (strlen xx)) (substr xx 5) )
( xx )
)
)
(substr (vl-prin1-to-string x) 7)
)
)
(setq r
'(
acLnWtByLayer acLnWtByBlock acLnWtByLwDefault
acLnWt000 acLnWt005 acLnWt009 acLnWt013 acLnWt015
acLnWt018 acLnWt020 acLnWt025 acLnWt030 acLnWt035 acLnWt040
acLnWt050 acLnWt053 acLnWt060 acLnWt070 acLnWt080 acLnWt090
acLnWt100 acLnWt106 acLnWt120 acLnWt140 acLnWt158 acLnWt200 acLnWt211
)
)
)
)
(end_list)
(set_tile k (itoa (vl-position def r)))
r
)
(_Linetype ( k def / d L )
(while (setq d (tblnext "LTYPE" (not d))) (setq L (cons (cdr (assoc 2 d)) L)))
(if L
(progn
(setq L (acad_strlsort L))
(start_list k) (mapcar 'add_list L) (end_list)
(set_tile k (itoa (vl-position def L)))
L
)
)
)
)
)
(defun *error* ( msg )
(and (< 0 dch) (unload_dialog dch))
(and (eq 'FILE (type des)) (close des))
(and (eq 'STR (type dcl)) (findfile dcl) (vl-file-delete dcl))
(and msg (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " msg)))) (princ)
)
(cond
(
(not
(and (setq dcl (vl-filename-mktemp nil nil ".dcl")) (setq des (open dcl "w"))
(mapcar (function (lambda (x) (princ (strcat "\n" x) des)))
'("test : dialog "
"{ label = \"Quick Layer\"; width = 36; spacer_1;"
" : boxed_column"
" { label = \"Input Layer Name\"; "
" : edit_box { key = \"lnm\"; fixed_width = false; }"
" spacer;"
" }"
" spacer_1;"
" : boxed_column"
" { alignment = centered; label = \"Layer Properties\"; children_fixed_width = false;"
" spacer;"
" : row"
" { "
" : text { label = \"Color\"; alignment = left; }"
" : spacer { width = 2.0; }"
" : image_button { key = \"col\"; width = 2.4; aspect_ratio = 1.8; color = graphics_background; fixed_width = false; } "
" }"
" : popup_list { label = \"Transparency\"; key = \"trn\"; edit_width = 6; }"
" : popup_list { label = \"Plottable?\"; key = \"plt\"; edit_width = 6; }"
" : popup_list { label = \"Lineweight\"; key = \"lw\"; edit_width = 16; }"
" : popup_list { label = \"Linetype\"; key = \"lt\"; edit_width = 16; }"
" spacer_1;"
" : row { alignment = centered; spacer; : toggle { label = \"Current?\"; key = \"cur\"; alignment = centered; value = 1; } } "
" spacer_1; "
" }"
" spacer_1; ok_cancel; errtile;"
"}"
)
)
(not (setq des (close des))) (< 0 (setq dch (load_dialog dcl)))
)
)
(prompt "\nUnable to write or load the DCL file.")
)
( (not (new_dialog "test" dch)) (prompt "\nUnable to display the dialog") )
(
(progn
(mode_tile "lnm" 2)
(ImageButtonColorPrompt "col" 20 'col)
(setq tmpL (apply 'mapcar (cons ''(( x k d ) ((cdr x) k d)) (cons (cdr tmpL) '(("trn" "plt" "lw" "lt") ("0" "Yes" acLnWtByLayer "Continuous"))))))
(foreach x '(lnm accept)
(action_tile (strcase (vl-prin1-to-string x) t)
(vl-prin1-to-string
'(
(lambda ( lnm / tmp )
(setq tmp (strcase lnm))
(cond
( (not (snvalid lnm)) (set_tile "error" (strcat "Invalid layer name: " lnm)) (if (= $key "lnm") (set_tile $key $data) (mode_tile "lnm" 2)) )
( (setq tmp (vl-some '(lambda (x) (if (= tmp (strcase x)) x)) layers)) (set_tile "error" (strcat "Layer \"" tmp "\" exists!")) (if (= $key "lnm") (set_tile $key $data) (mode_tile "lnm" 2)) )
(t (if (= $key "lnm") (client_data_tile $key lnm))
(set_tile "error" (strcat "Layername \"" lnm "\" is fine"))
(if
(or
(/= $key "lnm")
(and (= $key "lnm") (= 1 $reason))
)
(progn
(setq rtn
(append (list (cons 'col col))
(mapcar ''((x) (cons x (get_tile (strcase (vl-prin1-to-string x) t)))) '(lnm cur))
(mapcar ''((k a) (cons (read k) (nth (atoi (get_tile k)) a))) '("trn" "plt" "lw" "lt") tmpL)
)
)
(done_dialog 1)
)
)
)
)
)
(get_tile "lnm")
)
)
)
)
(/= 1 (setq dcf (start_dialog)))
)
(prompt "\nUser cancelled or terminated the dialog.")
)
(
(
'(( / f L )
(setq f '((k L)(cdr (assoc k L))))
(setq L (list (f 'lnm rtn) (f 'col rtn) (f 'lt rtn) (eval (f 'lw rtn)) (= "Yes" (f 'plt rtn)) (atoi (f 'trn rtn)) (= "1" (f 'cur rtn))))
(apply 'CreateLayer L)
)
)
)
)
(*error* nil) (princ)
)
; This one is assembled by Grrr...
; key - [STR] key of an image_button
; def - [INT] ACI value for the very first default color prompt
; sym - [SYM] symbol name to bound the value
; the return value is stored in the specified symbol
; Note1: the specified ACI color is stored in the tile's $data (so it would be default for further inputs)
; Note2: for true colors its recomended (LM:True->ACI) function
; Usage example: (ImageButtonColorPrompt "img1" 20 'col)
'(87 114 105 116 116 101 110 32 98 121 32 71 114 114 114)
(defun ImageButtonColorPrompt ( key def sym )
(action_tile key
(strcat
"(setq " (vl-prin1-to-string sym) " "
" ("
" (lambda ( def )"
(vl-prin1-to-string
(quote
(
(lambda ( / tmp val )
(if
(setq tmp
(acad_truecolordlg
(cond
( (and $data (/= $data "") (setq tmp (read $data)))
(cond
( (assoc 430 tmp) )
( (assoc 420 tmp) )
( (assoc 62 tmp) )
)
)
(def) (1)
)
t
)
)
(
(lambda ( k col / w h )
(setq w (1- (dimx_tile k))) (setq h (1- (dimy_tile k)))
(start_image k) (fill_image 0 0 w h col) (end_image)
(client_data_tile $key (vl-prin1-to-string tmp))
tmp
)
$key
(cond
( (and LM:True->ACI (setq val (cdr (assoc 420 tmp)))) (LM:True->ACI val) )
( (cdr (assoc 62 tmp)) )
)
)
)
)
)
)
)
" )"
(cond (def (vl-prin1-to-string def)) ("nil"))
" )"
")"
)
)
)
; This one is assembled by Grrr from Lee Mac's subfunctions here and there...
'(67 114 101 100 105 116 115 32 116 111 32 76 101 101 32 77 97 99)
(defun CreateLayer ( name colour linetype lineweight plot transparency makecurrent / rtn )
(regapp "accmtransparency")
(if (not (tblobjname "LAYER" name))
(setq rtn
(entmake
(append
'((0 . "LAYER")(100 . "AcDbSymbolTableRecord")(100 . "AcDbLayerTableRecord")(70 . 0))
(list (cons 2 name) (cons 6 (if (tblsearch "LTYPE" linetype) linetype "Continuous")) )
colour
(list (cons 290 (if plot 1 0)) (cons 370 lineweight) )
(if transparency
(list (list -3 (list "accmtransparency" (cons 1071 ( (lambda ( x ) (logior (fix (* 2.55 (- 100 x))) 33554432)) transparency )))))
)
)
)
)
)
(if makecurrent (setvar 'clayer name)) rtn
)
;; True -> ACI - Lee Mac
;; Args: c - [int] True Colour
(defun LM:True->ACI ( c / o r )
(apply 'LM:RGB->ACI (LM:True->RGB c))
)
;; RGB -> ACI - Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values
(defun LM:RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
;; 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))
)
;; Application Object - Lee Mac
;; Returns the VLA Application Object
(defun LM:acapp nil
(eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
(LM:acapp)
)
