COLOR hyperlinks lisp problem

[jim78b]

 

; 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 ]")

i have this lisp that changes the color temporarily to everything including blocks, I would like that when I refedit the color of the things out remains of the color chosen (example purple) by me and in the block with the original colors.

Another problem with this lisp that changes the scale of the lines and I don't know why.

thanks to all