[LISP函数]：TrueColor dialog function

mmmm · 发表于 2003-4-30 19:51:54

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;|
TrueColor function by KozMos 2003/04/30
Unique Function calling for AutoCAD ACI and TrueColor dialog, run under AutoCAD2002+
Call true color dialog or common color dialog automatically
Sub-functions all imported from AutoCAD2004 color-util.lsp
Input Var: ColorX [INTEGER]
If ColorX < 256, regard ColorX as ACI color, or treat it as TrueColor
If (null ColorX), set ColorX as 256 for BYLAYER
Return Vaue: Rtn [INTEGER]
If choose ACI color, return ACI color number (< 256)
If choose Colorbook (DXF430),convert color book name as truecolor number
If cancel the set color operation, return input color number
|;
(Defun acad_MColorDlg (ColorX /
TrueColor->ACI ACI->TrueColor
ColorName->TrueColor
RGB->TrueColor Color62
Color420 Code
Rtn
)
(Defun TrueColor->ACI
(TrueColor / TrueColor-split colorObj ci)
(Defun TrueColor-split (c)
(list (lsh (fix c) -16)
(lsh (lsh (fix c) 16) -24)
(lsh (lsh (fix c) 24) -24)
)
)
(vl-load-com)
(and (setq colorObj (vla-getinterfaceobject
(vlax-get-acad-object)
"AutoCAD.AcCmColor.16"
)
)
(not (vl-catch-all-error-p
(vl-catch-all-apply
'vla-setRGB
(cons colorObj (TrueColor-split TrueColor))
)
)
)
(setq ci (vla-get-ColorIndex colorObj))
)
ci
)
(Defun ACI->TrueColor (ci / colorObj TrueColor)
(vl-load-com)
(and (setq colorObj (vla-getinterfaceobject
(vlax-get-acad-object)
"AutoCAD.AcCmColor.16"
)
)
(>= ci 1)
(<= ci 255)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-put-ColorIndex (list colorObj ci))
)
)
(setq TrueColor (RGB->TrueColor
(list (vla-get-red colorObj)
(vla-get-green colorObj)
(vla-get-blue colorObj)
)
)
)
)
TrueColor
)
(Defun RGB->TrueColor (RGB / Red Green Blue Rtn)
(setq Red (nth 0 RGB)
Green (nth 1 RGB)
Blue (nth 2 RGB)
Rtn (+ (lsh (fix Red) 16)
(lsh (fix Green) 8)
(fix Blue)
)
)
Rtn
)
(Defun ColorName->TrueColor (colorbookandname
/ pos
colorbook colorname
colorObj TrueColor
)
(vl-load-com)
(and (equal (type colorbookandname) 'STR)
(setq pos (vl-string-search "$" colorbookandname))
(setq colorbook (substr colorbookandname 1 pos)
colorname (substr colorbookandname (+ pos 2))
)
(setq colorObj (vla-getinterfaceobject
(vlax-get-acad-object)
"AutoCAD.AcCmColor.16"
)
)
(not (vl-catch-all-error-p
(vl-catch-all-apply
'vla-SetColorBookColor
(list colorObj colorbook colorname)
)
)
)
(setq TrueColor (RGB->TrueColor
(list
(vla-get-red colorObj)
(vla-get-green colorObj)
(vla-get-blue colorObj)
)
)
)
)
TrueColor
)
(if (null ColorX)
(setq ColorX 256)
)
(if (> ColorX 256)
(setq Color62 (TrueColor->ACI ColorX)
Color420 ColorX
)
(setq Color420 (ACI->TrueColor ColorX)
Color62 ColorX
)
)
(if (null acad_truecolordlg)
(progn
(if (null (setq Rtn (acad_colordlg Color62)))
(setq Rtn Color62)
)
)
(progn
(if (> ColorX 256)
(setq Code "420 ")
(setq Code "62 ")
)
(if (null
(setq Rtn (eval (read (strcat "(acad_truecolordlg (cons "
Code
(rtos ColorX 2 0)
"))"
)
)
)
)
)
(setq Rtn ColorX)
(cond ((cdr (assoc 420 Rtn))
(setq Rtn (cdr (assoc 420 Rtn)))
)
((cdr (assoc 430 Rtn))
(setq Rtn (cdr (assoc 430 Rtn))
Rtn (ColorName->TrueColor Rtn)
)
)
((cdr (assoc 62 Rtn))
(setq Rtn (cdr (assoc 62 Rtn)))
)
)
)
)
)
Rtn
)

;| 
TrueColor function by KozMos 2003/04/30 
Unique Function calling for AutoCAD ACI and TrueColor dialog, run under AutoCAD2002+ 
Call true color dialog or common color dialog automatically 
Sub-functions all imported from AutoCAD2004 color-util.lsp 
 
Input Var: ColorX [INTEGER] 
           If ColorX < 256, regard ColorX as ACI color, or treat it as TrueColor 
           If (null ColorX), set ColorX as 256 for BYLAYER 
 
Return Vaue: Rtn [INTEGER] 
           If choose ACI color, return ACI color number (< 256) 
           If choose Colorbook (DXF430),convert color book name as truecolor number 
           If cancel the set color operation, return input color number 
|; 
(Defun acad_MColorDlg (ColorX                / 
                       TrueColor->ACI        ACI->TrueColor 
                       ColorName->TrueColor 
                       RGB->TrueColor        Color62 
                       Color420                Code 
                       Rtn 
                      ) 
  (Defun TrueColor->ACI 
                        (TrueColor / TrueColor-split colorObj ci) 
    (Defun TrueColor-split (c) 
      (list (lsh (fix c) -16) 
            (lsh (lsh (fix c) 16) -24) 
            (lsh (lsh (fix c) 24) -24) 
      ) 
    ) 
    (vl-load-com) 
    (and (setq colorObj        (vla-getinterfaceobject 
                          (vlax-get-acad-object) 
                          "AutoCAD.AcCmColor.16" 
                        ) 
         ) 
         (not (vl-catch-all-error-p 
                (vl-catch-all-apply 
                  'vla-setRGB 
                  (cons colorObj (TrueColor-split TrueColor)) 
                ) 
              ) 
         ) 
         (setq ci (vla-get-ColorIndex colorObj)) 
    ) 
    ci 
  ) 
  (Defun ACI->TrueColor        (ci / colorObj TrueColor) 
    (vl-load-com) 
    (and (setq colorObj        (vla-getinterfaceobject 
                          (vlax-get-acad-object) 
                          "AutoCAD.AcCmColor.16" 
                        ) 
         ) 
         (>= ci 1) 
         (<= ci 255) 
         (not 
           (vl-catch-all-error-p 
             (vl-catch-all-apply 'vla-put-ColorIndex (list colorObj ci)) 
           ) 
         ) 
         (setq TrueColor (RGB->TrueColor 
                           (list (vla-get-red colorObj) 
                                 (vla-get-green colorObj) 
                                 (vla-get-blue colorObj) 
                           ) 
                         ) 
         ) 
    ) 
    TrueColor 
  ) 
 
  (Defun RGB->TrueColor        (RGB / Red Green Blue Rtn) 
    (setq Red        (nth 0 RGB) 
          Green        (nth 1 RGB) 
          Blue        (nth 2 RGB) 
          Rtn        (+ (lsh (fix Red) 16) 
                   (lsh (fix Green) 8) 
                   (fix Blue) 
                ) 
    ) 
    Rtn 
  ) 
  (Defun ColorName->TrueColor (colorbookandname 
                               /             pos 
                               colorbook     colorname 
                               colorObj             TrueColor 
                              ) 
    (vl-load-com) 
    (and (equal (type colorbookandname) 'STR) 
         (setq pos (vl-string-search "$" colorbookandname)) 
         (setq colorbook (substr colorbookandname 1 pos) 
               colorname (substr colorbookandname (+ pos 2)) 
         ) 
         (setq colorObj        (vla-getinterfaceobject 
                          (vlax-get-acad-object) 
                          "AutoCAD.AcCmColor.16" 
                        ) 
         ) 
         (not (vl-catch-all-error-p 
                (vl-catch-all-apply 
                  'vla-SetColorBookColor 
                  (list colorObj colorbook colorname) 
                ) 
              ) 
         ) 
         (setq TrueColor (RGB->TrueColor 
                           (list 
                             (vla-get-red colorObj) 
                             (vla-get-green colorObj) 
                             (vla-get-blue colorObj) 
                           ) 
                         ) 
         ) 
    ) 
    TrueColor 
  ) 
  (if (null ColorX) 
    (setq ColorX 256) 
  ) 
  (if (> ColorX 256) 
    (setq Color62  (TrueColor->ACI ColorX) 
          Color420 ColorX 
    ) 
    (setq Color420 (ACI->TrueColor ColorX) 
          Color62  ColorX 
    ) 
  ) 
  (if (null acad_truecolordlg) 
    (progn 
      (if (null (setq Rtn (acad_colordlg Color62))) 
        (setq Rtn Color62) 
      ) 
    ) 
    (progn 
      (if (> ColorX 256) 
        (setq Code "420 ") 
        (setq Code "62 ") 
      ) 
      (if (null 
            (setq Rtn (eval (read (strcat "(acad_truecolordlg (cons " 
                                          Code 
                                          (rtos ColorX 2 0) 
                                          "))" 
                                  ) 
                            ) 
                      ) 
            ) 
          ) 
        (setq Rtn ColorX) 
        (cond ((cdr (assoc 420 Rtn)) 
               (setq Rtn (cdr (assoc 420 Rtn))) 
              ) 
              ((cdr (assoc 430 Rtn)) 
               (setq Rtn (cdr (assoc 430 Rtn)) 
                     Rtn (ColorName->TrueColor Rtn) 
               ) 
              ) 
              ((cdr (assoc 62 Rtn)) 
               (setq Rtn (cdr (assoc 62 Rtn))) 
              ) 
        ) 
      ) 
    ) 
  ) 
  Rtn 
)

账号		自动登录	找回密码
密码			立即注册

[LISP函数]：TrueColor dialog function

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子