[编程交流] 快速切换Autocad颜色Sch

;;-------------------=={ Color sheme }==------------------------;;
;;                                                              ;;
;;  Change the color scheme in AutoCAD (like WinAmp)            ;;
;;  the data of color schemes for AutoCAD stored in xml file    ;;
;;--------------------------------------------------------------;;
;; Author: Vladimir Azarko (VVA), Copyright © 2011 - www.dwg.ru ;;
;; Some of updates : Ketxu (Nguyen Son Tung                     ;;
;;--------------------------------------------------------------;;
;; Special thanks                                               ;;
;; gomer - idea                                                 ;;
;; Vov.ka - xml parser                                          ;;
;; Alexandr Rivilis - GetOleColor, GerRGB                       ;;
;;--------------------------------------------------------------;;
;; ALL RIGHTS REMOVED                                           ;;
;;--------------------------------------------------------------;;
;;--------------------------------------------------------------;;
(defun c:ACS()
(setq appRegPath "HKEY_CURRENT_USER\\Software\\ACS\")
(defun ACS:WK (key)(vl-registry-write (setq rt (strcat appRegPath key))) rt)
(defun ACS:WV (path key val)(vl-registry-write (ACS:WK path) key (vl-princ-to-string val))) ;Reg write
(defun ACS:W_Shema (x) (ACS:WV (car x) nil (cadr x)))
(defun ACS:RV (path key)(read(vl-registry-read (strcat appRegPath path) key))) ;Reg read
(defun ACS:Apply_Shema (themes)(mapcar '(lambda(x y) (set_shema (eval x)  y)) lstFunc_Put (ACS:RV themes nil)))
(defun ACS:Insert_Shema (sName lstColor) ;Insert Shema to Reg
(or sName (setq sName (strcat "Themes - " (menucmd (strcat "m=$(edtime,"  (rtos (getvar "DATE") 2  ",DD:MO:YY - HH:MM:SS)"))))) 
(ACS:W_Shema
(cons sName
    (list
    (cond 
        (lstColor)    
        (list
            ((lambda (display)
                (mapcar '(lambda (x)                                           
                              (GetRGB (vlax-variant-value
                                         (vlax-variant-change-type
                                           (eval (list x display))
                                           vlax-vblong
                                         ) ;_ end of vlax-variant-change-type
                                       ) ;_ end of vlax-variant-value
                               ) ;_ end of GetRGB                                                   
                         ) ;_ end of lambda
                        (list
                          'vla-get-graphicswinmodelbackgrndcolor
                          'vla-get-modelcrosshaircolor
                          'vla-get-textwinbackgrndcolor
                          'vla-get-textwintextcolor
                          'vla-get-graphicswinlayoutbackgrndcolor
                          'vla-get-layoutcrosshaircolor) ;_ end of list
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (vla-get-display
                 (vla-get-preferences (vlax-get-acad-object))
               ) ;_ end of vla-get-display
            ) 
        )
    )
    )
)
)
)
;;; A. Rivilis
(defun GetOleColor (r g b) (+ r (lsh g  (lsh b 16)))
(defun GetRGB (Olecolor)
  (list
    (logand Olecolor 255)
    ;; R
    (logand (lsh Olecolor - 255)
    ;; G
    (logand (lsh Olecolor -16) 255)
    ;; B
  ) ;_ end of list
) ;_ end of defun
(defun set_shema (func lst)
;;; func - function like 'vla-put-ModelCrosshairColor
;;; lst - RGB list (R G B) or (255 0 234)
  (func
    (vla-get-display
      (vla-get-preferences (vlax-get-acad-object))
    ) ;_ end of vla-get-display
    (vlax-make-variant (apply 'GetOleColor lst) vlax-vblong)
  ) ;_ end of func
) ;_ end of defun
;VVA : i change sth to learn about action in DCL
(defun mydcl (zagl info-list / fl ret dcl_id)
  (vl-load-com)
  (or zagl (setq zagl "Select"))
  (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
  (setq ret (open fl "w")
  ud (lambda()
            (start_list "info" 3)
            (mapcar 'add_list (setq info-list (acad_strlsort  (vl-registry-descendents  appRegPath))))
            (end_list))
    )
  (mapcar
    '(lambda (x) (write-line x ret))
    (list "mip_msg : dialog { "
          (strcat "label="" zagl "";")
          " :list_box {"
          "alignment=top ;width=51 ;allow_accept = true;"
          "tabs = "16 32";tab_truncate = true;"
            (if (> (length info-list) 26)
                "height= 26 ;"
                (strcat "height= " (itoa (+ 3 (length info-list))) ";")
            ) ;_ end of if
          "is_tab_stop = false ;"
          "key = "info";}"          
          " :row {"
          " :button {"
          "label=" OK ";"
          "key = "Accept";"
          "is_cancel = true;}"
          " :button {"
          "label="Apply";"
          "key = "kApply";}"
          " :button {"
          "label="Insert";"
          "key = "kInsert";}"    
          " :button {"
          "label="Delete";"
          "key = "kDelete";}"
          " :button {"
          "label="Cancel ";"
          "key = "kCancel";}"
          "}}"          
    ) ;_ end of list
  ) ;_ end of mapcar
  (setq ret (close ret))
  (if (and (not (minusp (setq dcl_id (load_dialog fl))))
           (new_dialog "mip_msg" dcl_id)
      ) ;_ end of and
    (progn
      (start_list "info")
      (mapcar 'add_list info-list)
      (end_list)
      (set_tile "info" "0")
      (setq ret (car info-list))
      (action_tile
        "info"
        "(setq ret (nth (atoi $value) info-list))"
      ) ;_ end of action_tile
      (action_tile
        "kCancel"
        "(progn(setq ret nil)(done_dialog 0))"
      ) ;_ end of action_tile
      (action_tile "Accept" "(done_dialog 1)")
      (action_tile "kApply" "(ACS:Apply_Shema (nth (atoi(get_tile "info")) info-list))")
      (action_tile "kInsert" "(ACS:Insert_Shema nil nil)(ud)")
      (action_tile "kDelete" "(vl-registry-delete (strcat appRegPath (nth (atoi(get_tile "info")) info-list)))(ud)")      
      (start_dialog)
    ) ;_ end of progn
  ) ;_ end of if
  (unload_dialog dcl_id)
  (vl-file-delete fl)
  ret)
(setq lstFunc_Put 
    '( 
    vla-put-GraphicsWinModelBackgrndColor
    vla-put-ModelCrosshairColor
    vla-put-TextWinBackgrndColor
    vla-put-TextWinTextColor
    vla-put-GraphicsWinLayoutBackgrndColor
    vla-put-LayoutCrosshairColor
    ))
(cond 
    ((not (vl-registry-descendents  appRegPath)) ;First run
        (mapcar 'ACS:W_Shema 
            (list
                (cons  "Classic"     (list (list '(0 0 0) '(255 255 255)  '(255 255 255) '(0 0 0) '(255 255 255) '(0 0 0))))                
                (cons  "Negative"     (list (list '(255 255 255) '(0 0 0) '(0 0 0) '(255 255 255) '(255 255 255) '(0 0 0))))
                (cons  "Winter"     (list (list '(214 214 214) '(0 0 0) '(255 255 255) '(0 0 0) '(255 255 255) '(0 0 0))))
                (cons  "The Matrix" (list (list '(0 0 0) '(0 255 0) '(0 0 0) '(0 255 0) '(255 255 255) '(0 0 0))))
                (cons  "Ocean"         (list (list '(0 0 0) '(255 255  255) '(0 173 173)  '(255 255 255) '(255 255 255) '(0 0 0))))
                (cons  "Pascal"     (list (list '(0 0 0) '(255 255 255) '(0 0 255) '(255 255 0) '(255 255 255) '(0 0 0))))
                (cons  "Sakura"     (list (list '(0 0 0) '(246 223 233) '(246 223 233) '(120 70 44) '(255 255 255) '(0 0 0))))
                (cons  "Deep dive"     (list (list '(38 40 48) '(127 159  255) '(38 40 48) '(127 159 255) '(51 102 255) '(0 0 0))))
            )
        )
    )
)
(if (setq item (mydcl "Select Shema to Apply :" (acad_strlsort  (vl-registry-descendents  appRegPath))))
    (ACS:Apply_Shema item)
)
)