Jump to content

Quick Switch Autocad Color Scheme

VVA

By VVA
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

VVA Rising Star

VVA

Posted
Posted

The program allows you to apply color schemes in AutoCAD (like WinAmp)

Settings are stored in xml file.

Dwgru_color_schema.xml file should be located in ways to support AutoCAD.

Defined by 2 commands:

ACS - applies the selected scheme

GetShema - printed in the text box fragment settings xml file for the current color scheme.

color sheme.ZIP

ketxu Community Regular

ketxu

Posted
Posted

Thanks VVA. It's new idea to relax eyes and some ex how to do with XML file ^^

VVA Rising Star

VVA

Posted
  • Author
Posted

Thank you for your interest. This code was written as a demonstration of the formation of a dialogue on the fly and store data in xml file.

ketxu Community Regular

ketxu

Posted
Posted

Hi VVA, it's funny to learn news ^^ I'm not good in XML structure, so i modified it to Registry store to make a new dirty verision, hope you don't mind.

And i want to ask how to use $Reason 4 to apply like pick Apply button when double click in one listbox' item. Some of example in InternEt not enough for my very low IQ score ^^ 

;;-------------------=={ 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)
)
)

ketxu Community Regular

ketxu

Posted
Posted

Thanks you VVA, it's useful, i've known what to do ^^

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.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...