【AutoLISP Visual LISP›】普通图元索引色修改为真彩色

admin1

lsp文件里面小程序包含2个简单的功能：

  C:ZCS  统一变成真彩色    【索引色所对应的真彩色】
  C:ZCM 各自变成真彩色    【索引色所对应的真彩色】



;;========================================================================================
;;统一变色
(defun C:ZCS( / ss ss_lst RGB RGB_str)
        (princ "\n 索引色改为真彩色--统一变色")
        (if (and
                                (setq ss (ssget))
                                (setq *cor_index* (ureal 1 "" "\n\t索引色号" *cor_index*))
                        )
                (progn
                        (UNDO_S)
                        (setq *error* *error*_E)
                        ;;=============================================================                       
                        (setq RGB (reverse (bb-COLORINDEX->TRUECOLOR *cor_index*)))
                        (setq RGB_str (strcat
                                                                                        (rtos (car RGB) 2 0)
                                                                                        ","
                                                                                        (rtos (cadr RGB) 2 0)
                                                                                        ","
                                                                                        (rtos (caddr RGB) 2 0)
                                                                                )
                        )
                        ;;=============================================================
                        (setvar "CMDECHO" 0)
                        (command "CHPROP" ss "" "C" "T" RGB_str "")       
                        (setvar "CMDECHO" 1)
                        (princ "\n 索引色改为真彩色--统一变色完成")
                        ;;=============================================================
                        (UNDO_E)                       
                        (princ)
                )
        )
)
;;========================================================================================
;;各自变色
(defun C:ZCM( / ss ss_lst ename elist cor tc RGB RGB_str CMDECHO_old)
        (princ "\n 索引色改为真彩色--各自变色")
        (if (setq ss (ssget))
                (progn
                        (defun *error* (msg)
                                (if (= 8 (logand (getvar "undoctl") 8))
                                        (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
                                )       
                                (if CMDECHO_old  (setvar "CMDECHO" CMDECHO_old))
                        )
                        (UNDO_S)
                        (setq CMDECHO_old (getvar "CMDECHO"))
                        (setvar "CMDECHO" 0)
                        ;;=============================================================
                        (setq ss_lst (ss-enlst ss))
                        (foreach ename ss_lst
                                ;;=============================================================
                                (setq elist(entget ename))
                                (if (setq cor (assoc 62 elist));线型如果随层,按图层线型
                                        (princ)
                                        (progn
                                                (setq tc (cdr (assoc 8 elist)));随层,获取图层线型
                                                (setq tc (tblsearch "layer" tc));;图层信息
                                                (setq cor (assoc 62 tc));;查询图层线型
                                        )
                                )
                                ;;=============================================================
                                (setq RGB (reverse (bb-COLORINDEX->TRUECOLOR (cdr cor))))
                                (setq RGB_str (strcat
                                                                                                (rtos (car RGB) 2 0)
                                                                                                ","
                                                                                                (rtos (cadr RGB) 2 0)
                                                                                                ","
                                                                                                (rtos (caddr RGB) 2 0)
                                                                                        )
                                )
                                ;;=============================================================
                                (command "CHPROP" (ssadd ename) "" "C" "T" RGB_str "")       
                                ;;=============================================================                                       
                        )
                        (princ "\n 索引色改为真彩色--各自变色--修改完成")
                        (setvar "CMDECHO" CMDECHO_old)
                        (UNDO_E)               
                        (princ)
                )
        )
)
;;========================================================================================
;;索引色转真彩色
(defun bb-ColorIndex->Truecolor        (col / Truecolor color)
        (setq TrueColor(vla-get-TrueColor(vlax-ename->vla-object(tblobjname "layer""0"))))
        (setq colorIndex (vla-get-colorIndex Truecolor))
        (vla-put-ColorIndex Truecolor col)
        (setq color
                (mapcar
                        '(lambda(x)(vlax-get TrueColor x))
                        '(Blue Green Red)
                )
        )
        (vla-put-colorIndex Truecolor colorIndex)
        color
)
;;========================================================================================
;选择集与对象名表互转
(defun ss-enlst        (ss / enlst)
        (cond
                ((= (type ss) 'PICKSET)
                        (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
                )
                ((= (type ss) 'LIST)
                        (setq enlst (ssadd))
                        (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
                )
        )
)
;;========================================================================================               
;;编组出错处理
(defun *error*_E(MSG)
        (if (= 8 (logand (getvar "undoctl") 8))
                (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
        )               
)
;;========================================================================================               
;;undo结束
(defun UNDO_E()
        (if (= 8 (logand (getvar "undoctl") 8))
                (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
        )               
)
;;========================================================================================                       
;;undo开始
(defun UNDO_S()
        (undo_e)       
        (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
)
;;========================================================================================               
(defun ureal (bit kwd msg def / inp)
        (if def
                (setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")
                        bit (* 2 (fix (/ bit 2)))
                )
                (setq msg (strcat "\n" msg ": "))
        )
        (initget bit kwd)
        (setq inp (getreal msg))
        (if inp inp def)
)