exceed Posted March 18, 2022 Posted March 18, 2022 (edited) On 3/17/2022 at 9:08 AM, BIGAL said: exceed welcome to use this Have you looked at ( setq colnum (acad_colordlg 1) pick any color probably what I would use saves need more defuns. or (if (not AH:Butts)(load "Multi Radio buttons.lsp")) (if (= but nil)(setq but 1)) (ah:butts but "V" '("Choose a color" "yellow" "green" "cyan" "blue" "magenta" "white" "gray" "light" "gray" "purple")) ; the variable BUT inside the code holds the button selected value can use that for this post Multi GETVALS.lsp 2.75 kB · 17 downloads ; make it color with dcl - 2022.03.18 exceed ; this lisp use object's hyperlink property ; command list ; mip - change color for all ; mips - change color for 1 selected object(blocks) (defun c:mip ( / answer ) ; Multi button Dialog box for a single choice repalcment of initget ; By Alan H Feb 2019 ; Example code as the radio button click will close the default button setting is required ; if you have defined a default setting ; (if (not AH:Butts)(load "Multi radio buttons.lsp")) ; loads the program if not loaded already ; (if (= but nil)(setq but 1)) ; this is needed to set default button ; you can reset default button to user pick ; (setq ans (ah:butts but "V" '("A B C D " "A" "B" "C" "D" ))) ; ans holds the button picked value as a string ; if you want ans a number use (atof ans) or (atoi ans) ; (if (not AH:Butts)(load "Multi Radio buttons.lsp")) ; (if (= but nil)(setq but 1)) ; (setq ans (ah:butts but "h" '("Yes or No" "Yes" "No"))) ; ans holds the button picked value ; (if (not AH:Butts)(load "Multi Radio buttons.lsp")) ; (if (= but nil)(setq but 1)) ; (setq ans (atoi(ah:butts but "V" '("Choose a number" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")))) ; ans holds the button picked as an integer value (vl-load-com) (defun AH:Butts (AHdef verhor butlst / fo fname x k ) (setq fo (open (setq fname (vl-filename-mktemp "" "" ".dcl")) "w")) (write-line "AHbutts : dialog {" fo) (write-line (strcat " label =" (chr 34) (nth 0 butlst) (chr 34) " ;" )fo) (write-line " : row {" fo) (if (= (strcase verhor) "V") (progn (write-line " : boxed_radio_column {" fo) (write-line (strcat " width = " (rtos (+ (strlen (nth 0 butlst)) 15) 2 0) " ;") fo) ; increase 10 if label does not appear ) (progn (write-line " : boxed_radio_row {" fo) (write-line (strcat " width = " (rtos (+ (strlen (nth 0 butlst)) 15) 2 0) " ;") fo) ; increase 10 if label does not appear ) ) (setq x 1) (repeat (- (length butlst) 1) (write-line " : radio_button {" fo) (write-line (strcat "key = " (chr 34) "Rb" (rtos x 2 0) (chr 34) ";") fo) (write-line (strcat "label = " (chr 34) (nth x butlst) (chr 34) ";") fo) (write-line " }" fo) ;(write-line "spacer_1 ;" fo) (setq x (+ x 1)) ) (write-line "spacer_1 ;" fo) (write-line " }" fo) (write-line " }" fo) (write-line "spacer_1 ;" fo) (write-line " ok_only;" fo) (write-line " }" fo) (close fo) (setq dcl_id (load_dialog fname)) (if (not (new_dialog "AHbutts" dcl_id) ) (exit) ) (setq x 1) (repeat (- (length butlst) 1) (setq k (strcat "Rb" (rtos x 2 0))) (action_tile k (strcat "(setq but " (rtos x 2 0) ")" "(done_dialog)")) (if (= ahdef x)(set_tile k "1")) (setq x (+ x 1)) ) (set_tile "Rb1" "1") (action_tile "accept" (strcat "(setq but " (rtos ahdef 2 0) ")" "(done_dialog)")) (start_dialog) (unload_dialog dcl_id) (vl-file-delete fname) (nth but butlst) ) (if (= but nil)(setq but 1)) (setq answer (ah:butts but "V" '("Choose a color for all" "return-to-origin" "red" "yellow" "green" "cyan" "blue" "magenta" "white" "gray" "lightgray" "gray" "purple"))) ; the variable BUT inside the code holds the button selected value can use that for this post ; (princ answer) (cond ((= answer "return-to-origin") (ex:mic)) ((= answer "red") (ex:mip 1)) ((= answer "yellow") (ex:mip 2)) ((= answer "green") (ex:mip 3)) ((= answer "cyan") (ex:mip 4)) ((= answer "blue") (ex:mip 5)) ((= answer "magenta") (ex:mip 6)) ((= answer "white") (ex:mip 7)) ((= answer "gray") (ex:mip 8)) ((= answer "lightgray") (ex:mip 9)) ((= answer "purple") (ex:mip 200)) );end of cond (princ) ) (defun c:mips ( / answer ) ; Multi button Dialog box for a single choice repalcment of initget ; By Alan H Feb 2019 ; Example code as the radio button click will close the default button setting is required ; if you have defined a default setting ; (if (not AH:Butts)(load "Multi radio buttons.lsp")) ; loads the program if not loaded already ; (if (= but nil)(setq but 1)) ; this is needed to set default button ; you can reset default button to user pick ; (setq ans (ah:butts but "V" '("A B C D " "A" "B" "C" "D" ))) ; ans holds the button picked value as a string ; if you want ans a number use (atof ans) or (atoi ans) ; (if (not AH:Butts)(load "Multi Radio buttons.lsp")) ; (if (= but nil)(setq but 1)) ; (setq ans (ah:butts but "h" '("Yes or No" "Yes" "No"))) ; ans holds the button picked value ; (if (not AH:Butts)(load "Multi Radio buttons.lsp")) ; (if (= but nil)(setq but 1)) ; (setq ans (atoi(ah:butts but "V" '("Choose a number" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")))) ; ans holds the button picked as an integer value (vl-load-com) (defun AH:Butts (AHdef verhor butlst / fo fname x k ) (setq fo (open (setq fname (vl-filename-mktemp "" "" ".dcl")) "w")) (write-line "AHbutts : dialog {" fo) (write-line (strcat " label =" (chr 34) (nth 0 butlst) (chr 34) " ;" )fo) (write-line " : row {" fo) (if (= (strcase verhor) "V") (progn (write-line " : boxed_radio_column {" fo) (write-line (strcat " width = " (rtos (+ (strlen (nth 0 butlst)) 15) 2 0) " ;") fo) ; increase 10 if label does not appear ) (progn (write-line " : boxed_radio_row {" fo) (write-line (strcat " width = " (rtos (+ (strlen (nth 0 butlst)) 15) 2 0) " ;") fo) ; increase 10 if label does not appear ) ) (setq x 1) (repeat (- (length butlst) 1) (write-line " : radio_button {" fo) (write-line (strcat "key = " (chr 34) "Rb" (rtos x 2 0) (chr 34) ";") fo) (write-line (strcat "label = " (chr 34) (nth x butlst) (chr 34) ";") fo) (write-line " }" fo) ;(write-line "spacer_1 ;" fo) (setq x (+ x 1)) ) (write-line "spacer_1 ;" fo) (write-line " }" fo) (write-line " }" fo) (write-line "spacer_1 ;" fo) (write-line " ok_only;" fo) (write-line " }" fo) (close fo) (setq dcl_id (load_dialog fname)) (if (not (new_dialog "AHbutts" dcl_id) ) (exit) ) (setq x 1) (repeat (- (length butlst) 1) (setq k (strcat "Rb" (rtos x 2 0))) (action_tile k (strcat "(setq but " (rtos x 2 0) ")" "(done_dialog)")) (if (= ahdef x)(set_tile k "1")) (setq x (+ x 1)) ) (set_tile "Rb1" "1") (action_tile "accept" (strcat "(setq but " (rtos ahdef 2 0) ")" "(done_dialog)")) (start_dialog) (unload_dialog dcl_id) (vl-file-delete fname) (nth but butlst) ) (if (= but nil)(setq but 1)) (setq answer (ah:butts but "V" '("Choose a color for one" "return-to-origin" "red" "yellow" "green" "cyan" "blue" "magenta" "white" "gray" "lightgray" "gray" "purple"))) ; the variable BUT inside the code holds the button selected value can use that for this post ; (princ answer) (cond ((= answer "return-to-origin") (ex:mics)) ((= answer "red") (ex:mips 1)) ((= answer "yellow") (ex:mips 2)) ((= answer "green") (ex:mips 3)) ((= answer "cyan") (ex:mips 4)) ((= answer "blue") (ex:mips 5)) ((= answer "magenta") (ex:mips 6)) ((= answer "white") (ex:mips 7)) ((= answer "gray") (ex:mips 8)) ((= answer "lightgray") (ex:mips 9)) ((= answer "purple") (ex:mips 200)) );end of cond (princ) ) (vl-load-com) (defun ex:mip ( setcolor / blkss blk ent edata blknames setcolor_txt c_lyrs lock_lst *error* ss ssl index obj color linetype linetypescale str en check index1 obj1 en1 ssblk ssblkindex blkent blk ent enx obj2 color2 linetype2 linetypescale2 str2 hlinks2 ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (cond ((= setcolor 1) (setq setcolor_txt "red") ) ((= setcolor 2) (setq setcolor_txt "yellow") ) ((= setcolor 3) (setq setcolor_txt "green") ) ((= setcolor 4) (setq setcolor_txt "cyan") ) ((= setcolor 5) (setq setcolor_txt "blue") ) ((= setcolor 6) (setq setcolor_txt "magenta") ) ((= setcolor 7) (setq setcolor_txt "white") ) ((= setcolor 8) (setq setcolor_txt "gray") ) ((= setcolor 9) (setq setcolor_txt "lightgray") ) ((= setcolor 200) (setq setcolor_txt "purple") ) );end of cond (princ "\n make it ") (princ setcolor_txt) (princ " - processing ") (if (setq ss (ssget "X")) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) ;(vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq old_str "") (vlax-for each (vlax-get-property obj 'Hyperlinks) (setq old_str (strcat (vla-get-url each))) ) ;(princ "\n old_str - ") ;(princ old_str) (if (/= (substr old_str 1 3) "MIP") (progn ;(princ "\n modify") (setq color (vl-princ-to-string (vla-get-color obj))) (setq linetype (vl-princ-to-string (vla-get-linetype obj))) (setq linetypescale (vl-princ-to-string (vla-get-linetypescale obj))) (setq str (strcat "MIP/" color "/" linetype "/" linetypescale)) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks str) ) (progn ;(princ "\n stay") (vla-add (vlax-get-property obj 'Hyperlinks) old_str) ) ) (setq index (+ index 1)) );end of repeat (setq index1 0) (repeat ssl (setq en1 (ssname ss index1)) (setq obj1 (vlax-ename->vla-object (cdr (assoc -1 (entget en1))))) (setq check (vlax-property-available-p obj1 "Color" T)) (if check (vlax-put-property obj1 'Color setcolor) ) (vla-put-linetype obj1 "continuous") (vla-put-linetypescale obj1 1) (setq index1 (+ index1 1)) );end of repeat );end of progn );end of if (if (setq blkss (ssget "x" '((0 . "insert")) )) (progn (repeat (setq inc (sslength blkss)); get names from initial selection (setq blk (ssname blkss (setq inc (1- inc)))) (nametolist blk) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [done this way instead of via (repeat) or (foreach), so it can add nested Blocks' names to the list] (setq ent (tblobjname "block" blk)); Block definition as entity (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 (setq obj (vlax-ename->vla-object ent)) (setq old_str "") (vlax-for each (vlax-get-property obj 'Hyperlinks) (setq old_str (strcat (vla-get-url each))) ) ;(princ "\n old_str - ") ;(princ old_str) (if (/= (substr old_str 1 3) "MIP") (progn ;(princ "\n modify") (setq color (vl-princ-to-string (vla-get-color obj))) (setq linetype (vl-princ-to-string (vla-get-linetype obj))) (setq linetypescale (vl-princ-to-string (vla-get-linetypescale obj))) (setq str (strcat "MIP/" color "/" linetype "/" linetypescale)) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks str) );end of progn (progn ;(princ "\n stay") (vla-add (vlax-get-property obj 'Hyperlinks) old_str) );end of progn );end of if (if (vlax-property-available-p obj 'Linetype) (vla-put-linetype obj "continuous") ) (vla-put-color obj setcolor); color ByLayer (vla-put-linetypescale obj1 1) ); while -- sub-entities (setq blknames (cdr blknames)); take first one off ); while );end of progn );end of if (rh:relock_lyrs lock_lst) (vla-regen (LM:acdoc) acallviewports) (princ "\n make it ") (princ setcolor_txt) (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun ;mip for single selection (defun ex:mips ( setcolor / blkss blk ent edata blknames setcolor_txt c_lyrs lock_lst *error* ss ssl index obj color linetype linetypescale str en check index1 obj1 en1 ssblk ssblkindex blkent blk ent enx obj2 color2 linetype2 linetypescale2 str2 hlinks2 ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (cond ((= setcolor 1) (setq setcolor_txt "red") ) ((= setcolor 2) (setq setcolor_txt "yellow") ) ((= setcolor 3) (setq setcolor_txt "green") ) ((= setcolor 4) (setq setcolor_txt "cyan") ) ((= setcolor 5) (setq setcolor_txt "blue") ) ((= setcolor 6) (setq setcolor_txt "magenta") ) ((= setcolor 7) (setq setcolor_txt "white") ) ((= setcolor 8) (setq setcolor_txt "gray") ) ((= setcolor 9) (setq setcolor_txt "lightgray") ) ((= setcolor 200) (setq setcolor_txt "purple") ) );end of cond (princ "\n make it ") (princ setcolor_txt) (princ " - processing ") (if (setq ss (ssget ":S")) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) ;(vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq old_str "") (vlax-for each (vlax-get-property obj 'Hyperlinks) (setq old_str (strcat (vla-get-url each))) ) ;(princ "\n old_str - ") ;(princ old_str) (if (/= (substr old_str 1 3) "MIP") (progn ;(princ "\n modify") (setq color (vl-princ-to-string (vla-get-color obj))) (setq linetype (vl-princ-to-string (vla-get-linetype obj))) (setq linetypescale (vl-princ-to-string (vla-get-linetypescale obj))) (setq str (strcat "MIP/" color "/" linetype "/" linetypescale)) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks str) ) (progn ;(princ "\n stay") (vla-add (vlax-get-property obj 'Hyperlinks) old_str) ) ) (setq index (+ index 1)) );end of repeat (setq index1 0) (repeat ssl (setq en1 (ssname ss index1)) (setq obj1 (vlax-ename->vla-object (cdr (assoc -1 (entget en1))))) (setq check (vlax-property-available-p obj1 "Color" T)) (if check (vlax-put-property obj1 'Color setcolor) ) (vla-put-linetype obj1 "continuous") (vla-put-linetypescale obj1 1) (setq index1 (+ index1 1)) );end of repeat );end of progn );end of if (if (setq blkss (ssget "P" '((0 . "insert")) )) (progn (repeat (setq inc (sslength blkss)); get names from initial selection (setq blk (ssname blkss (setq inc (1- inc)))) (nametolist blk) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [done this way instead of via (repeat) or (foreach), so it can add nested Blocks' names to the list] (setq ent (tblobjname "block" blk)); Block definition as entity (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 (setq obj (vlax-ename->vla-object ent)) (setq old_str "") (vlax-for each (vlax-get-property obj 'Hyperlinks) (setq old_str (strcat (vla-get-url each))) ) ;(princ "\n old_str - ") ;(princ old_str) (if (/= (substr old_str 1 3) "MIP") (progn ;(princ "\n modify") (setq color (vl-princ-to-string (vla-get-color obj))) (setq linetype (vl-princ-to-string (vla-get-linetype obj))) (setq linetypescale (vl-princ-to-string (vla-get-linetypescale obj))) (setq str (strcat "MIP/" color "/" linetype "/" linetypescale)) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks str) );end of progn (progn ;(princ "\n stay") (vla-add (vlax-get-property obj 'Hyperlinks) old_str) );end of progn );end of if (if (vlax-property-available-p obj 'Linetype) (vla-put-linetype obj "continuous") ) (vla-put-color obj setcolor); color ByLayer (vla-put-linetypescale obj1 1) ); while -- sub-entities (setq blknames (cdr blknames)); take first one off ); while );end of progn );end of if (rh:relock_lyrs lock_lst) (vla-regen (LM:acdoc) acallviewports) (princ "\n make it ") (princ setcolor_txt) (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun (defun ex:mic ( / blkss blk ent edata blknames c_lyrs lock_lst *error* ssblk ssblkl ssblkindex blk ent enx str2 obj2 hlinks2 strlist2 color2 linetype2 linetypescale2 check ss ssl index obj color linetype linetypescale str layertable newlayername en check strlist ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (princ "\n make it color (return to origin) - processing ") (if (setq blkss (ssget "x" '((0 . "insert")) )) (progn (repeat (setq inc (sslength blkss)); get names from initial selection (setq blk (ssname blkss (setq inc (1- inc)))) (nametolist blk) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [done this way instead of via (repeat) or (foreach), so it can add nested Blocks' names to the list] (setq ent (tblobjname "block" blk)); Block definition as entity (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 (setq obj2 (vlax-ename->vla-object ent)) (setq str2 "") (setq hlinks2 (vlax-get-property obj2 'Hyperlinks)) (vlax-for each hlinks2 (setq str2 (strcat (vla-get-url each))) ) (if (/= str2 "") (progn (setq strlist2 '()) (setq strlist2 (LM:str->lst str2 "/")) (setq color2 (cadr strlist2)) (setq linetype2 (caddr strlist2)) (setq linetypescale2 (nth 3 strlist2)) (setq check (vlax-property-available-p obj2 "Color" T)) (if check (vlax-put-property obj2 'Color color2) ) (vla-put-linetype obj2 linetype2) (vla-put-linetypescale obj2 linetypescale2) (vlax-for x (vla-get-hyperlinks obj2) (vla-delete x)) ); end of progn );end of if ); while -- sub-entities (setq blknames (cdr blknames)); take first one off ); while );end of progn );end of if (if (setq ss (ssget "X" '((-3 ("PE_URL"))))) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vlax-for each hlinks (setq str (strcat (vla-get-url each))) ) (setq strlist (LM:str->lst str "/")) (setq color (cadr strlist)) (setq linetype (caddr strlist)) (setq linetypescale (nth 3 strlist)) (setq check (vlax-property-available-p obj "Color" T)) (if check (vlax-put-property obj 'Color color) ) (vla-put-linetype obj linetype) (vla-put-linetypescale obj linetypescale) (vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq index (+ index 1)) );end of repeat );end of progn );end of if (rh:relock_lyrs lock_lst) (vla-regen (LM:acdoc) acallviewports) (princ "\n make it color (return to origin)") (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun ;mic for single selection (defun ex:mics ( / ssorigin blkss blk ent edata blknames c_lyrs lock_lst *error* ssblk ssblkl ssblkindex blk ent enx str2 obj2 hlinks2 strlist2 color2 linetype2 linetypescale2 check ss ssl index obj color linetype linetypescale str layertable newlayername en check strlist ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (setq ssorigin (ssget ":s")) (princ "\n make it color (return to origin) - processing ") (if (setq blkss (ssget "P" '((0 . "insert")) )) (progn (repeat (setq inc (sslength blkss)); get names from initial selection (setq blk (ssname blkss (setq inc (1- inc)))) (nametolist blk) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [done this way instead of via (repeat) or (foreach), so it can add nested Blocks' names to the list] (setq ent (tblobjname "block" blk)); Block definition as entity (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 (setq obj2 (vlax-ename->vla-object ent)) (setq str2 "") (setq hlinks2 (vlax-get-property obj2 'Hyperlinks)) (vlax-for each hlinks2 (setq str2 (strcat (vla-get-url each))) ) (if (/= str2 "") (progn (setq strlist2 '()) (setq strlist2 (LM:str->lst str2 "/")) (setq color2 (cadr strlist2)) (setq linetype2 (caddr strlist2)) (setq linetypescale2 (nth 3 strlist2)) (setq check (vlax-property-available-p obj2 "Color" T)) (if check (vlax-put-property obj2 'Color color2) ) (vla-put-linetype obj2 linetype2) (vla-put-linetypescale obj2 linetypescale2) (vlax-for x (vla-get-hyperlinks obj2) (vla-delete x)) ); end of progn );end of if ); while -- sub-entities (setq blknames (cdr blknames)); take first one off ); while );end of progn );end of if (command "_.SELECT" ssorigin "") (if (setq ss (ssget "P" '((-3 ("PE_URL"))))) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vlax-for each hlinks (setq str (strcat (vla-get-url each))) ) (setq strlist (LM:str->lst str "/")) (setq color (cadr strlist)) (setq linetype (caddr strlist)) (setq linetypescale (nth 3 strlist)) (setq check (vlax-property-available-p obj "Color" T)) (if check (vlax-put-property obj 'Color color) ) (vla-put-linetype obj linetype) (vla-put-linetypescale obj linetypescale) (vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq index (+ index 1)) );end of repeat );end of progn );end of if (rh:relock_lyrs lock_lst) (vla-regen (LM:acdoc) acallviewports) (princ "\n make it color (return to origin)") (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun ;; Active Document - Lee Mac ;; Returns the VLA Active Document Object (defun LM:acdoc nil (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) (LM:acdoc) ) ;; Start Undo - Lee Mac ;; Opens an Undo Group. (defun LM:startundo ( doc ) (LM:endundo doc) (vla-startundomark doc) ) ;; End Undo - Lee Mac ;; Closes an Undo Group. (defun LM:endundo ( doc ) (while (= 8 (logand 8 (getvar 'undoctl))) (vla-endundomark doc) ) ) ;; String to List - Lee Mac ;; Separates a string using a given delimiter ;; str - [str] String to process ;; del - [str] Delimiter by which to separate the string ;; Returns: [lst] List of strings (defun LM:str->lst ( str del / pos ) (if (setq pos (vl-string-search del str)) (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del)) (list str) ) ) ; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/create-list-of-locked-layers-lock-amp-unlock-again/m-p/9306234/highlight/true#M395697 ;; unlock all layers : requires list of locked layer objects (defun rh:unlock_lyrs (lst) (mapcar '(lambda (x) (vlax-put-property x 'lock :vlax-false)) lst) );end_defun ;; relock all previously locked layers : requires list of locked layer objects (defun rh:relock_lyrs (lst) (mapcar '(lambda (x) (vlax-put-property x 'lock :vlax-true)) lst) );end_defun ;return list of locked layer objects : requires layer collection (defun rh:lock_lyr_list (lyrs / lst) (if (= "AcDbLayerTable" (vlax-get-property lyrs 'objectname)) (vlax-map-collection lyrs '(lambda (x) (if (= :vlax-true (vlax-get-property x 'lock)) (setq lst (cons x lst))))) );end_if lst );end_defun ;; BlockSParts0Bylayer.lsp ;; = change all Parts of definitions of Selected Block(s) [other ;; than on Layer Defpoints] to Layer 0 with Color ByLayer ;; Kent Cooper, 3 November 2014 ;; Modified by Alan h OCT 2020 ;; now does linetype only (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 (princ "\n make it color - loading complete") I applied your Multi radio buttons.lsp to this routine. thank you for your help. Since it is 1 column, the command is divided into mip and mips. If I use dcl well, I think I can make a better Lisp. Lisp is something new to learn every day. ------------------------------------------------------------------------------------------------------------------- success to 2 column! My duct tape modifications made it no longer a generally available module, but it was nice to be able to study dcl. ; make it color with dcl - 2022.03.18 exceed ; this lisp use object's hyperlink property ; command list ; mic - change color for all or one (defun c:mic ( / answer ) ; Multi button Dialog box for a single choice repalcment of initget ; By Alan H Feb 2019 ; Example code as the radio button click will close the default button setting is required ; if you have defined a default setting ; (if (not AH:Butts)(load "Multi radio buttons.lsp")) ; loads the program if not loaded already ; (if (= but nil)(setq but 1)) ; this is needed to set default button ; you can reset default button to user pick ; (setq ans (ah:butts but "V" '("A B C D " "A" "B" "C" "D" ))) ; ans holds the button picked value as a string ; if you want ans a number use (atof ans) or (atoi ans) ; (if (not AH:Butts)(load "Multi Radio buttons.lsp")) ; (if (= but nil)(setq but 1)) ; (setq ans (ah:butts but "h" '("Yes or No" "Yes" "No"))) ; ans holds the button picked value ; (if (not AH:Butts)(load "Multi Radio buttons.lsp")) ; (if (= but nil)(setq but 1)) ; (setq ans (atoi(ah:butts but '("Choose a number" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")))) ; ans holds the button picked as an integer value (vl-load-com) (defun AH:Butts (AHdef butlst / fo fname x k ) (setq fo (open (setq fname (vl-filename-mktemp "" "" ".dcl")) "w")) (write-line "AHbutts : dialog {" fo) (write-line (strcat " label =" (chr 34) (nth 0 butlst) (chr 34) " ;" )fo) (write-line " : row {" fo) (write-line " : boxed_radio_column {" fo) (write-line (strcat "key = " (chr 34) "For ALL" (chr 34) ";") fo) (write-line (strcat "label = " (chr 34) "For ALL" (chr 34) ";") fo) (write-line (strcat " width = " (rtos (+ (strlen (nth 0 butlst)) 15) 2 0) " ;") fo) ; increase 10 if label does not appear (setq x 1) (repeat 12 (write-line " : radio_button {" fo) (write-line (strcat "key = " (chr 34) "Rb" (rtos x 2 0) (chr 34) ";") fo) (write-line (strcat "label = " (chr 34) (nth x butlst) (chr 34) ";") fo) (write-line " }" fo) (setq x (+ x 1)) ) (write-line "spacer_1 ;" fo) (write-line " }" fo) (write-line " : boxed_radio_column {" fo) (write-line (strcat "key = " (chr 34) "For ONE" (chr 34) ";") fo) (write-line (strcat "label = " (chr 34) "For ONE" (chr 34) ";") fo) (write-line (strcat " width = " (rtos (+ (strlen (nth 0 butlst)) 15) 2 0) " ;") fo) ; increase 10 if label does not appear (repeat 12 (write-line " : radio_button {" fo) (write-line (strcat "key = " (chr 34) "Rb" (rtos x 2 0) (chr 34) ";") fo) (write-line (strcat "label = " (chr 34) (nth x butlst) (chr 34) ";") fo) (write-line " }" fo) (setq x (+ x 1)) ) (write-line "spacer_1 ;" fo) (write-line " }" fo) (write-line " }" fo) (write-line "spacer_1 ;" fo) (write-line " ok_only;" fo) (write-line " }" fo) (close fo) (setq dcl_id (load_dialog fname)) (if (not (new_dialog "AHbutts" dcl_id) ) (exit) ) (setq x 1) (repeat 24 (setq k (strcat "Rb" (rtos x 2 0))) (action_tile k (strcat "(setq but " (rtos x 2 0) ")" "(done_dialog)")) (if (= ahdef x)(set_tile k "1")) (setq x (+ x 1)) ) (set_tile "Rb1" "1") (action_tile "accept" (strcat "(setq but " (rtos ahdef 2 0) ")" "(done_dialog)")) (start_dialog) (unload_dialog dcl_id) (vl-file-delete fname) (nth but butlst) ) (if (= but nil)(setq but 1)) (setq answer (ah:butts but '("MIC - Choose a color" "return-to-origin" "red" "yellow" "green" "cyan" "blue" "magenta" "white" "gray" "lightgray" "gray" "purple" "return-to-origin1" "red1" "yellow1" "green1" "cyan1" "blue1" "magenta1" "white1" "gray1" "lightgray1" "gray1" "purple1"))) ; the variable BUT inside the code holds the button selected value can use that for this post ; (princ answer) (cond ((= answer "return-to-origin") (ex:mic)) ((= answer "red") (ex:mip 1)) ((= answer "yellow") (ex:mip 2)) ((= answer "green") (ex:mip 3)) ((= answer "cyan") (ex:mip 4)) ((= answer "blue") (ex:mip 5)) ((= answer "magenta") (ex:mip 6)) ((= answer "white") (ex:mip 7)) ((= answer "gray") (ex:mip 8)) ((= answer "lightgray") (ex:mip 9)) ((= answer "purple") (ex:mip 200)) ((= answer "return-to-origin1") (ex:mics)) ((= answer "red1") (ex:mips 1)) ((= answer "yellow1") (ex:mips 2)) ((= answer "green1") (ex:mips 3)) ((= answer "cyan1") (ex:mips 4)) ((= answer "blue1") (ex:mips 5)) ((= answer "magenta1") (ex:mips 6)) ((= answer "white1") (ex:mips 7)) ((= answer "gray1") (ex:mips 8)) ((= answer "lightgray1") (ex:mips 9)) ((= answer "purple1") (ex:mips 200)) );end of cond (princ) ) (vl-load-com) (defun ex:mip ( setcolor / blkss blk ent edata blknames setcolor_txt c_lyrs lock_lst *error* ss ssl index obj color linetype linetypescale str en check index1 obj1 en1 ssblk ssblkindex blkent blk ent enx obj2 color2 linetype2 linetypescale2 str2 hlinks2 ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (cond ((= setcolor 1) (setq setcolor_txt "red") ) ((= setcolor 2) (setq setcolor_txt "yellow") ) ((= setcolor 3) (setq setcolor_txt "green") ) ((= setcolor 4) (setq setcolor_txt "cyan") ) ((= setcolor 5) (setq setcolor_txt "blue") ) ((= setcolor 6) (setq setcolor_txt "magenta") ) ((= setcolor 7) (setq setcolor_txt "white") ) ((= setcolor 8) (setq setcolor_txt "gray") ) ((= setcolor 9) (setq setcolor_txt "lightgray") ) ((= setcolor 200) (setq setcolor_txt "purple") ) );end of cond (princ "\n make it ") (princ setcolor_txt) (princ " - processing ") (if (setq ss (ssget "X")) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) ;(vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq old_str "") (vlax-for each (vlax-get-property obj 'Hyperlinks) (setq old_str (strcat (vla-get-url each))) ) ;(princ "\n old_str - ") ;(princ old_str) (if (/= (substr old_str 1 3) "MIP") (progn ;(princ "\n modify") (setq color (vl-princ-to-string (vla-get-color obj))) (setq linetype (vl-princ-to-string (vla-get-linetype obj))) (setq linetypescale (vl-princ-to-string (vla-get-linetypescale obj))) (setq str (strcat "MIP/" color "/" linetype "/" linetypescale)) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks str) ) (progn ;(princ "\n stay") (vla-add (vlax-get-property obj 'Hyperlinks) old_str) ) ) (setq index (+ index 1)) );end of repeat (setq index1 0) (repeat ssl (setq en1 (ssname ss index1)) (setq obj1 (vlax-ename->vla-object (cdr (assoc -1 (entget en1))))) (setq check (vlax-property-available-p obj1 "Color" T)) (if check (vlax-put-property obj1 'Color setcolor) ) (vla-put-linetype obj1 "continuous") (vla-put-linetypescale obj1 1) (setq index1 (+ index1 1)) );end of repeat );end of progn );end of if (if (setq blkss (ssget "x" '((0 . "insert")) )) (progn (repeat (setq inc (sslength blkss)); get names from initial selection (setq blk (ssname blkss (setq inc (1- inc)))) (nametolist blk) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [done this way instead of via (repeat) or (foreach), so it can add nested Blocks' names to the list] (setq ent (tblobjname "block" blk)); Block definition as entity (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 (setq obj (vlax-ename->vla-object ent)) (setq old_str "") (vlax-for each (vlax-get-property obj 'Hyperlinks) (setq old_str (strcat (vla-get-url each))) ) ;(princ "\n old_str - ") ;(princ old_str) (if (/= (substr old_str 1 3) "MIP") (progn ;(princ "\n modify") (setq color (vl-princ-to-string (vla-get-color obj))) (setq linetype (vl-princ-to-string (vla-get-linetype obj))) (setq linetypescale (vl-princ-to-string (vla-get-linetypescale obj))) (setq str (strcat "MIP/" color "/" linetype "/" linetypescale)) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks str) );end of progn (progn ;(princ "\n stay") (vla-add (vlax-get-property obj 'Hyperlinks) old_str) );end of progn );end of if (if (vlax-property-available-p obj 'Linetype) (vla-put-linetype obj "continuous") ) (vla-put-color obj setcolor); color ByLayer (vla-put-linetypescale obj1 1) ); while -- sub-entities (setq blknames (cdr blknames)); take first one off ); while );end of progn );end of if (rh:relock_lyrs lock_lst) (vla-regen (LM:acdoc) acallviewports) (princ "\n make it ") (princ setcolor_txt) (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun ;mip for single selection (defun ex:mips ( setcolor / blkss blk ent edata blknames setcolor_txt c_lyrs lock_lst *error* ss ssl index obj color linetype linetypescale str en check index1 obj1 en1 ssblk ssblkindex blkent blk ent enx obj2 color2 linetype2 linetypescale2 str2 hlinks2 ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (cond ((= setcolor 1) (setq setcolor_txt "red") ) ((= setcolor 2) (setq setcolor_txt "yellow") ) ((= setcolor 3) (setq setcolor_txt "green") ) ((= setcolor 4) (setq setcolor_txt "cyan") ) ((= setcolor 5) (setq setcolor_txt "blue") ) ((= setcolor 6) (setq setcolor_txt "magenta") ) ((= setcolor 7) (setq setcolor_txt "white") ) ((= setcolor 8) (setq setcolor_txt "gray") ) ((= setcolor 9) (setq setcolor_txt "lightgray") ) ((= setcolor 200) (setq setcolor_txt "purple") ) );end of cond (princ "\n make it ") (princ setcolor_txt) (princ " - processing ") (if (setq ss (ssget ":S")) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) ;(vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq old_str "") (vlax-for each (vlax-get-property obj 'Hyperlinks) (setq old_str (strcat (vla-get-url each))) ) ;(princ "\n old_str - ") ;(princ old_str) (if (/= (substr old_str 1 3) "MIP") (progn ;(princ "\n modify") (setq color (vl-princ-to-string (vla-get-color obj))) (setq linetype (vl-princ-to-string (vla-get-linetype obj))) (setq linetypescale (vl-princ-to-string (vla-get-linetypescale obj))) (setq str (strcat "MIP/" color "/" linetype "/" linetypescale)) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks str) ) (progn ;(princ "\n stay") (vla-add (vlax-get-property obj 'Hyperlinks) old_str) ) ) (setq index (+ index 1)) );end of repeat (setq index1 0) (repeat ssl (setq en1 (ssname ss index1)) (setq obj1 (vlax-ename->vla-object (cdr (assoc -1 (entget en1))))) (setq check (vlax-property-available-p obj1 "Color" T)) (if check (vlax-put-property obj1 'Color setcolor) ) (vla-put-linetype obj1 "continuous") (vla-put-linetypescale obj1 1) (setq index1 (+ index1 1)) );end of repeat );end of progn );end of if (if (setq blkss (ssget "P" '((0 . "insert")) )) (progn (repeat (setq inc (sslength blkss)); get names from initial selection (setq blk (ssname blkss (setq inc (1- inc)))) (nametolist blk) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [done this way instead of via (repeat) or (foreach), so it can add nested Blocks' names to the list] (setq ent (tblobjname "block" blk)); Block definition as entity (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 (setq obj (vlax-ename->vla-object ent)) (setq old_str "") (vlax-for each (vlax-get-property obj 'Hyperlinks) (setq old_str (strcat (vla-get-url each))) ) ;(princ "\n old_str - ") ;(princ old_str) (if (/= (substr old_str 1 3) "MIP") (progn ;(princ "\n modify") (setq color (vl-princ-to-string (vla-get-color obj))) (setq linetype (vl-princ-to-string (vla-get-linetype obj))) (setq linetypescale (vl-princ-to-string (vla-get-linetypescale obj))) (setq str (strcat "MIP/" color "/" linetype "/" linetypescale)) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks str) );end of progn (progn ;(princ "\n stay") (vla-add (vlax-get-property obj 'Hyperlinks) old_str) );end of progn );end of if (if (vlax-property-available-p obj 'Linetype) (vla-put-linetype obj "continuous") ) (vla-put-color obj setcolor); color ByLayer (vla-put-linetypescale obj1 1) ); while -- sub-entities (setq blknames (cdr blknames)); take first one off ); while );end of progn );end of if (rh:relock_lyrs lock_lst) (vla-regen (LM:acdoc) acallviewports) (princ "\n make it ") (princ setcolor_txt) (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun (defun ex:mic ( / blkss blk ent edata blknames c_lyrs lock_lst *error* ssblk ssblkl ssblkindex blk ent enx str2 obj2 hlinks2 strlist2 color2 linetype2 linetypescale2 check ss ssl index obj color linetype linetypescale str layertable newlayername en check strlist ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (princ "\n make it color (return to origin) - processing ") (if (setq blkss (ssget "x" '((0 . "insert")) )) (progn (repeat (setq inc (sslength blkss)); get names from initial selection (setq blk (ssname blkss (setq inc (1- inc)))) (nametolist blk) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [done this way instead of via (repeat) or (foreach), so it can add nested Blocks' names to the list] (setq ent (tblobjname "block" blk)); Block definition as entity (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 (setq obj2 (vlax-ename->vla-object ent)) (setq str2 "") (setq hlinks2 (vlax-get-property obj2 'Hyperlinks)) (vlax-for each hlinks2 (setq str2 (strcat (vla-get-url each))) ) (if (/= str2 "") (progn (setq strlist2 '()) (setq strlist2 (LM:str->lst str2 "/")) (setq color2 (cadr strlist2)) (setq linetype2 (caddr strlist2)) (setq linetypescale2 (nth 3 strlist2)) (setq check (vlax-property-available-p obj2 "Color" T)) (if check (vlax-put-property obj2 'Color color2) ) (vla-put-linetype obj2 linetype2) (vla-put-linetypescale obj2 linetypescale2) (vlax-for x (vla-get-hyperlinks obj2) (vla-delete x)) ); end of progn );end of if ); while -- sub-entities (setq blknames (cdr blknames)); take first one off ); while );end of progn );end of if (if (setq ss (ssget "X" '((-3 ("PE_URL"))))) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vlax-for each hlinks (setq str (strcat (vla-get-url each))) ) (setq strlist (LM:str->lst str "/")) (setq color (cadr strlist)) (setq linetype (caddr strlist)) (setq linetypescale (nth 3 strlist)) (setq check (vlax-property-available-p obj "Color" T)) (if check (vlax-put-property obj 'Color color) ) (vla-put-linetype obj linetype) (vla-put-linetypescale obj linetypescale) (vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq index (+ index 1)) );end of repeat );end of progn );end of if (rh:relock_lyrs lock_lst) (vla-regen (LM:acdoc) acallviewports) (princ "\n make it color (return to origin)") (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun ;mic for single selection (defun ex:mics ( / ssorigin blkss blk ent edata blknames c_lyrs lock_lst *error* ssblk ssblkl ssblkindex blk ent enx str2 obj2 hlinks2 strlist2 color2 linetype2 linetypescale2 check ss ssl index obj color linetype linetypescale str layertable newlayername en check strlist ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (setq ssorigin (ssget ":s")) (princ "\n make it color (return to origin) - processing ") (if (setq blkss (ssget "P" '((0 . "insert")) )) (progn (repeat (setq inc (sslength blkss)); get names from initial selection (setq blk (ssname blkss (setq inc (1- inc)))) (nametolist blk) ); repeat (while (setq blk (car blknames)); as long as there's another Block name in list ;; [done this way instead of via (repeat) or (foreach), so it can add nested Blocks' names to the list] (setq ent (tblobjname "block" blk)); Block definition as entity (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 (setq obj2 (vlax-ename->vla-object ent)) (setq str2 "") (setq hlinks2 (vlax-get-property obj2 'Hyperlinks)) (vlax-for each hlinks2 (setq str2 (strcat (vla-get-url each))) ) (if (/= str2 "") (progn (setq strlist2 '()) (setq strlist2 (LM:str->lst str2 "/")) (setq color2 (cadr strlist2)) (setq linetype2 (caddr strlist2)) (setq linetypescale2 (nth 3 strlist2)) (setq check (vlax-property-available-p obj2 "Color" T)) (if check (vlax-put-property obj2 'Color color2) ) (vla-put-linetype obj2 linetype2) (vla-put-linetypescale obj2 linetypescale2) (vlax-for x (vla-get-hyperlinks obj2) (vla-delete x)) ); end of progn );end of if ); while -- sub-entities (setq blknames (cdr blknames)); take first one off ); while );end of progn );end of if (command "_.SELECT" ssorigin "") (if (setq ss (ssget "P" '((-3 ("PE_URL"))))) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vlax-for each hlinks (setq str (strcat (vla-get-url each))) ) (setq strlist (LM:str->lst str "/")) (setq color (cadr strlist)) (setq linetype (caddr strlist)) (setq linetypescale (nth 3 strlist)) (setq check (vlax-property-available-p obj "Color" T)) (if check (vlax-put-property obj 'Color color) ) (vla-put-linetype obj linetype) (vla-put-linetypescale obj linetypescale) (vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq index (+ index 1)) );end of repeat );end of progn );end of if (rh:relock_lyrs lock_lst) (vla-regen (LM:acdoc) acallviewports) (princ "\n make it color (return to origin)") (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun ;; Active Document - Lee Mac ;; Returns the VLA Active Document Object (defun LM:acdoc nil (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) (LM:acdoc) ) ;; Start Undo - Lee Mac ;; Opens an Undo Group. (defun LM:startundo ( doc ) (LM:endundo doc) (vla-startundomark doc) ) ;; End Undo - Lee Mac ;; Closes an Undo Group. (defun LM:endundo ( doc ) (while (= 8 (logand 8 (getvar 'undoctl))) (vla-endundomark doc) ) ) ;; String to List - Lee Mac ;; Separates a string using a given delimiter ;; str - [str] String to process ;; del - [str] Delimiter by which to separate the string ;; Returns: [lst] List of strings (defun LM:str->lst ( str del / pos ) (if (setq pos (vl-string-search del str)) (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del)) (list str) ) ) ; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/create-list-of-locked-layers-lock-amp-unlock-again/m-p/9306234/highlight/true#M395697 ;; unlock all layers : requires list of locked layer objects (defun rh:unlock_lyrs (lst) (mapcar '(lambda (x) (vlax-put-property x 'lock :vlax-false)) lst) );end_defun ;; relock all previously locked layers : requires list of locked layer objects (defun rh:relock_lyrs (lst) (mapcar '(lambda (x) (vlax-put-property x 'lock :vlax-true)) lst) );end_defun ;return list of locked layer objects : requires layer collection (defun rh:lock_lyr_list (lyrs / lst) (if (= "AcDbLayerTable" (vlax-get-property lyrs 'objectname)) (vlax-map-collection lyrs '(lambda (x) (if (= :vlax-true (vlax-get-property x 'lock)) (setq lst (cons x lst))))) );end_if lst );end_defun ;; BlockSParts0Bylayer.lsp ;; = change all Parts of definitions of Selected Block(s) [other ;; than on Layer Defpoints] to Layer 0 with Color ByLayer ;; Kent Cooper, 3 November 2014 ;; Modified by Alan h OCT 2020 ;; now does linetype only (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 (princ "\n make it color - loading complete") Edited March 18, 2022 by exceed Quote
jim78b Posted March 18, 2022 Author Posted March 18, 2022 I don't think I'll ever learn to code. it's difficult. Quote
jim78b Posted March 18, 2022 Author Posted March 18, 2022 i tried it thanks but in my case don't return in original state. have good day Quote
BIGAL Posted March 19, 2022 Posted March 19, 2022 (edited) For Exceed 2 columns just never posted it. I was going to make a new multi radio buttons that could have as many columns as you like so a list of lists approach 1 -> a practical limit. The other thing I think its in Multi getvals if only a few items has double spacing could add also to radio buttons. (cond ((= answer "return-to-origin") (ex:mic)) ((= answer "red") (ex:mip 1)) ((= answer "yellow") (ex:mip 2)) (cond ((= but 1) (ex:mic)) ((= but 2) (ex:mip 1)) ((= but 3) (ex:mip 2)) Multi radio buttons 2col.lsp Edited March 19, 2022 by BIGAL 1 Quote
jim78b Posted March 19, 2022 Author Posted March 19, 2022 It Is a good lisp, but i am sad because is terribly slow . Quote
Steven P Posted March 19, 2022 Posted March 19, 2022 7 hours ago, jim78b said: It Is a good lisp, but i am sad because is terribly slow . Faster than doing it yourself? 1 Quote
jim78b Posted March 19, 2022 Author Posted March 19, 2022 I don't understand this arrogance. I always thanks and be kind. Quote
Steven P Posted March 19, 2022 Posted March 19, 2022 8 hours ago, jim78b said: I don't understand this arrogance. I always thanks and be kind. It is not an arrogance, everyone always appreciates praise when they have helped - which you do do. Maybe I took your comment the wrong way - as a thanks but also a criticism - perhaps lost the meaning with the typed word on the screen - which is the basis of my comment - it is better than doing it all manually. 1 Quote
jim78b Posted November 9, 2022 Author Posted November 9, 2022 sorry , your lisp works!!! today I realized that it works, but every time I press a command es 1,2,3,4,5 then I have to press esc because if not it stops, can you please change the lisp so that it works? thank you ; make it color - 2022.03.15 exceed ; this lisp use object's hyperlink property ; command list ; ` = make it color (return to origin) leftside of "1" key ; 1 = make it red ; 2 = make it yellow ; 3 = make it green ; 4 = make it cyan ; 5 = make it blue ; 6 = make it magenta ; 7 = make it white ; 8 = make it gray ; 9 = make it light gray ; 0 = make it purple (defun c:` () (ex:mic) (princ)) ;make it color (return to origin) (defun c:1 () (ex:mip 1) (princ)) ;make it red (defun c:2 () (ex:mip 2) (princ)) ;make it yellow (defun c:3 () (ex:mip 3) (princ)) ;make it green (defun c:4 () (ex:mip 4) (princ)) ;make it cyan (defun c:5 () (ex:mip 5) (princ)) ;make it blue (defun c:6 () (ex:mip 6) (princ)) ;make it magenta (defun c:7 () (ex:mip 7) (princ)) ;make it white (defun c:8 () (ex:mip 8) (princ)) ;make it gray (defun c:9 () (ex:mip 9) (princ)) ;make it lightgray (defun c:0 () (ex:mip 200) (princ)) ;make it purple (vl-load-com) (defun ex:mip ( setcolor / setcolor_txt c_lyrs lock_lst *error* ss ssl index obj color linetype linetypescale str en check index1 obj1 en1 ssblk ssblkindex blkent blk ent enx obj2 color2 linetype2 linetypescale2 str2 hlinks2 ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (cond ((= setcolor 1) (setq setcolor_txt "red") ) ((= setcolor 2) (setq setcolor_txt "yellow") ) ((= setcolor 3) (setq setcolor_txt "green") ) ((= setcolor 4) (setq setcolor_txt "cyan") ) ((= setcolor 5) (setq setcolor_txt "blue") ) ((= setcolor 6) (setq setcolor_txt "magenta") ) ((= setcolor 7) (setq setcolor_txt "white") ) ((= setcolor 8) (setq setcolor_txt "gray") ) ((= setcolor 9) (setq setcolor_txt "lightgray") ) ((= setcolor 200) (setq setcolor_txt "purple") ) );end of cond (princ "\n make it ") (princ setcolor_txt) (princ " - processing ") (if (setq ss (ssget "X")) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) ;(vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq old_str "") (vlax-for each (vlax-get-property obj 'Hyperlinks) (setq old_str (strcat (vla-get-url each))) ) ;(princ "\n old_str - ") ;(princ old_str) (if (/= (substr old_str 1 3) "MIP") (progn ;(princ "\n modify") (setq color (vl-princ-to-string (vla-get-color obj))) (setq linetype (vl-princ-to-string (vla-get-linetype obj))) (setq linetypescale (vl-princ-to-string (vla-get-linetypescale obj))) (setq str (strcat "MIP/" color "/" linetype "/" linetypescale)) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks str) ) (progn ;(princ "\n stay") (vla-add (vlax-get-property obj 'Hyperlinks) old_str) ) ) (setq index (+ index 1)) );end of repeat (setq index1 0) (repeat ssl (setq en1 (ssname ss index1)) (setq obj1 (vlax-ename->vla-object (cdr (assoc -1 (entget en1))))) (setq check (vlax-property-available-p obj1 "Color" T)) (if check (vlax-put-property obj1 'Color setcolor) ) (vla-put-linetype obj1 "continuous") (vla-put-linetypescale obj1 1) (setq index1 (+ index1 1)) );end of repeat );end of progn );end of if (if (setq ssblk (ssget "x" '((0 . "insert")) )) (progn (setq ssblkl (sslength ssblk)) (setq ssblkindex 0) (repeat ssblkl (setq blkent (entget (ssname ssblk ssblkindex))) (setq blk (cdr (assoc 2 blkent))) (if (setq ent (tblobjname "BLOCK" blk)) (progn (while (and (setq ent (entnext ent))) (setq enx (entget ent)) (setq obj2 (vlax-ename->vla-object (cdr (assoc -1 enx)))) ;(vlax-for x (vla-get-hyperlinks obj2) (vla-delete x)) (setq old_str2 "") (vlax-for each (vlax-get-property obj2 'Hyperlinks) (setq old_str2 (strcat (vla-get-url each))) ) ;(princ "\n old_str2 - ") ;(princ old_str2) (if (/= (substr old_str2 1 3) "MIP") (progn ;(princ "\n modify") (setq color2 (vl-princ-to-string (vla-get-color obj2))) (setq linetype2 (vl-princ-to-string (vla-get-linetype obj2))) (setq linetypescale2 (vl-princ-to-string (vla-get-linetypescale obj2))) (setq str2 (strcat "MIP/" color2 "/" linetype2 "/" linetypescale2)) (setq hlinks2 (vlax-get-property obj2 'Hyperlinks)) (vla-add hlinks2 str2) ) (progn ;(princ "\n stay") (vla-add (vlax-get-property obj2 'Hyperlinks) old_str2) ) ) );end of while );end of progn );end of if (setq ssblkindex (+ ssblkindex 1)) );end of repeat (setq ssblkindex 0) (repeat ssblkl (setq blkent (entget (ssname ssblk ssblkindex))) (setq blk (cdr (assoc 2 blkent))) (if (setq ent (tblobjname "BLOCK" blk)) (progn (while (and (setq ent (entnext ent))) (setq enx (entget ent)) (setq obj2 (vlax-ename->vla-object (cdr (assoc -1 enx)))) (setq check (vlax-property-available-p obj2 "Color" T)) (if check (vlax-put-property obj2 'Color setcolor) ) (vla-put-linetype obj2 "continuous") (vla-put-linetypescale obj2 1) );end of while );end of progn );end of if (setq ssblkindex (+ ssblkindex 1)) );end of repeat );end of progn );end of if (rh:relock_lyrs lock_lst) (princ "\n make it ") (princ setcolor_txt) (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun (defun ex:mic ( / c_lyrs lock_lst *error* ssblk ssblkl ssblkindex blk ent enx str2 obj2 hlinks2 strlist2 color2 linetype2 linetypescale2 check ss ssl index obj color linetype linetypescale str layertable newlayername en check strlist ) (setvar 'cmdecho 0) (LM:startundo (LM:acdoc)) (defun *error* ( msg ) (rh:relock_lyrs lock_lst) (LM:endundo (LM:acdoc)) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq c_lyrs (vla-get-layers (LM:acdoc))) (setq lock_lst (rh:lock_lyr_list c_lyrs)) (rh:unlock_lyrs lock_lst) (princ "\n make it color (return to origin) - processing ") (if (setq ssblk (ssget "x" '((0 . "insert")) )) (progn (setq ssblkl (sslength ssblk)) (setq ssblkindex 0) (repeat ssblkl (setq blkent (entget (ssname ssblk ssblkindex))) (setq blk (cdr (assoc 2 blkent))) (if (setq ent (tblobjname "BLOCK" blk)) (progn (while (and (setq ent (entnext ent))) (setq enx (entget ent)) (setq str2 "") (setq obj2 (vlax-ename->vla-object (cdr (assoc -1 enx)))) (setq hlinks2 (vlax-get-property obj2 'Hyperlinks)) (vlax-for each hlinks2 (setq str2 (strcat (vla-get-url each))) ) (if (/= str2 "") (progn (setq strlist2 '()) (setq strlist2 (LM:str->lst str2 "/")) (setq color2 (cadr strlist2)) (setq linetype2 (caddr strlist2)) (setq linetypescale2 (nth 3 strlist2)) (setq check (vlax-property-available-p obj2 "Color" T)) (if check (vlax-put-property obj2 'Color color2) ) (vla-put-linetype obj2 linetype2) (vla-put-linetypescale obj2 linetypescale2) (vlax-for x (vla-get-hyperlinks obj2) (vla-delete x)) ); end of progn );end of if );end of while );end of progn );end of if (setq ssblkindex (+ ssblkindex 1)) );end of repeat );end of progn );end of if (if (setq ss (ssget "X" '((-3 ("PE_URL"))))) (progn (setq ssl 0) (setq ssl (sslength ss)) (setq index 0) (setq str "") (repeat ssl (setq en (ssname ss index)) (setq obj (vlax-ename->vla-object (cdr (assoc -1 (entget en))))) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vlax-for each hlinks (setq str (strcat (vla-get-url each))) ) (setq strlist (LM:str->lst str "/")) (setq color (cadr strlist)) (setq linetype (caddr strlist)) (setq linetypescale (nth 3 strlist)) (setq check (vlax-property-available-p obj "Color" T)) (if check (vlax-put-property obj 'Color color) ) (vla-put-linetype obj linetype) (vla-put-linetypescale obj linetypescale) (vlax-for x (vla-get-hyperlinks obj) (vla-delete x)) (setq index (+ index 1)) );end of repeat );end of progn );end of if (rh:relock_lyrs lock_lst) (princ "\n make it color (return to origin)") (princ " - complete!") (LM:endundo (LM:acdoc)) (setvar 'cmdecho 1) (princ) );end of defun ;; Active Document - Lee Mac ;; Returns the VLA Active Document Object (defun LM:acdoc nil (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) (LM:acdoc) ) ;; Start Undo - Lee Mac ;; Opens an Undo Group. (defun LM:startundo ( doc ) (LM:endundo doc) (vla-startundomark doc) ) ;; End Undo - Lee Mac ;; Closes an Undo Group. (defun LM:endundo ( doc ) (while (= 8 (logand 8 (getvar 'undoctl))) (vla-endundomark doc) ) ) ;; String to List - Lee Mac ;; Separates a string using a given delimiter ;; str - [str] String to process ;; del - [str] Delimiter by which to separate the string ;; Returns: [lst] List of strings (defun LM:str->lst ( str del / pos ) (if (setq pos (vl-string-search del str)) (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del)) (list str) ) ) ; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/create-list-of-locked-layers-lock-amp-unlock-again/m-p/9306234/highlight/true#M395697 ;; unlock all layers : requires list of locked layer objects (defun rh:unlock_lyrs (lst) (mapcar '(lambda (x) (vlax-put-property x 'lock :vlax-false)) lst) );end_defun ;; relock all previously locked layers : requires list of locked layer objects (defun rh:relock_lyrs (lst) (mapcar '(lambda (x) (vlax-put-property x 'lock :vlax-true)) lst) );end_defun ;return list of locked layer objects : requires layer collection (defun rh:lock_lyr_list (lyrs / lst) (if (= "AcDbLayerTable" (vlax-get-property lyrs 'objectname)) (vlax-map-collection lyrs '(lambda (x) (if (= :vlax-true (vlax-get-property x 'lock)) (setq lst (cons x lst))))) );end_if lst );end_defun (princ "\n make it color - loading complete") (princ "\n command [ ` - return / 1 - red / 2 - yellow / 3 - green / 4 - cyan / 5 - blue / 6 - magenta / 7 - white / 8 - gray / 9 - light gray / 0 - purple ]") Quote
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.