[LISP程序]：颜色转换工具

xyz · 发表于 2003-5-15 14:37:52

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

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

×

(defun c:cc (/ ent dcl_id)
(setq olderr *error*
*error* err
)
(setvar "CMDECHO" 0)
(if (not rescan)
(scan)
)
(setq lst lay_lst)
(if blk_lst
(foreach x blk_lst
(if (not (member x lst))
(setq lst (cons x lst))
)
)
)
(if ent_lst
(foreach x ent_lst
(if (not (member x lst))
(setq lst (cons x lst))
)
)
)
(setq str_lst nil)
(foreach x lst
(setq chk$ x)
(if (member x lay_lst)
(setq chk$ (strcat chk$ " L"))
)
(if (member x blk_lst)
(setq chk$ (strcat chk$ " B"))
)
(if (member x ent_lst)
(setq chk$ (strcat chk$ " E"))
)
(setq str_lst (cons chk$ str_lst))
)
(setq str_lst (reverse str_lst))
(setq nlst nil)
(foreach x lst (setq nlst (cons (list x x) nlst)))
(setq nlst (reverse nlst))
(setq lst nlst)
(if lst
(progn
(if (> (setq dcl_id (load_dialog "cc.dcl")) 0)
(progn (setq LST_ID 0)
(setq oldcolor (car (nth LST_ID lst)))
(setq newcolor (cadr (nth LST_ID lst)))
(if (not (new_dialog "color" dcl_id))
(exit)
)
(upd_lstbox "LST_BOX" lst)
(action_tile
"LST_BOX"
"(setq LST_ID (fix (atof $value))) (change_colors) "
)
(action_tile "new_col" "(get_color) (change_colors)")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog)")
(action_tile "LOAD" "(load_colors)")
(action_tile "SAVE" "(save_colors)")
(change_colors)
(setq start (start_dialog))
(if (= start 1)
(progn (setq rescan nil) (go_change))
(setq rescan T)
)
)
(prompt "\nDialoogbox not found.")
)
)
(alert "No entities in drawing.")
)
(setq *error* olderr)
(princ)
)
(defun go_change (/ tel color1 color2 x ss _lst rst entl kleur nent)
(prompt "\nCHANGING COLORS")
(prompt "\nENTITIES...")
(command "_UNDO" "_G")
(foreach x lst
(if (member (car x) ent_lst)
(progn (setq color1 (car x))
(setq color2 (cadr x))
(if (/= color1 color2)
(progn (prompt (strcat "\nChanging color "
color1 " to color "
color2 "."
)
)
(setq ss (cdr (assoc (fix (atof color1)) sslst)))
(command "_CHPROP" ss "" "_COLOR" color2 "")
)
)
)
)
)
(princ "done")
(prompt "\nBLOCKS...")
(setq _lst lst)
(foreach x _lst
(setq color1 (car x))
(setq color2 (cadr x))
(if (and (member color1 blk_lst) (/= color1 color2))
(progn
(setq rst 1)
(while (setq blk (tblnext "BLOCK" rst))
(setq rst nil)
(setq ent (dxf -2 blk))
(setq entl (entget ent))
(setq kleur (dxf 62 entl)
nent ent
)
(if (and kleur (= kleur (fix (atof color1))))
(progn (setq entl (subst (cons 62 (fix (atof color2)))
(assoc 62 entl)
entl
)
)
(entmod entl)
)
)
(while (setq nent (entnext nent))
(if (/= "SEQEND" (dxf 0 (setq entl (entget nent))))
(progn (setq kleur (dxf 62 entl))
(if (and kleur (= kleur (fix (atof color1))))
(progn (setq entl (subst (cons 62 (fix (atof color2)))
(assoc 62 entl)
entl
)
)
(entmod entl)
)
)
)
)
)
)
)
)
)
(princ "done")
(prompt "\nLAYERS...")
(foreach x lst
(setq color1 (car x))
(setq color2 (cadr x))
(setq rst T)
(if (and (member color1 lay_lst) (/= color1 color2))
(while (setq l (tblnext "LAYER" rst))
(setq col (rtos (dxf 62 l) 2 0)
$layer (dxf 2 l)
rst nil
)
(if (= col color1)
(command "_LAYER" "_COLOR" (fix (atof color2)) $layer "")
)
)
)
)
(princ "done.")
(command "_regen")
(command "_UNDO" "_END")
(initget "")
(command "_REDRAW")
(princ)
)
(defun upd_lstbox (k$ lst /)
(if lst
(progn (start_list k$)
(foreach x str_lst (add_list x))
(end_list)
)
(progn (start_list k$) (add_list "") (end_list))
)
)
(defun draw_color (oldcolnr newcolnr /)
(start_image "old_col")
(fill_image
0
0
(dimx_tile "old_col")
(dimy_tile "old_col")
(fix (atof oldcolnr))
)
(end_image)
(start_image "new_col")
(fill_image
0
0
(dimx_tile "new_col")
(dimy_tile "new_col")
(fix (atof newcolnr))
)
(end_image)
(set_tile "newnum" "")
(set_tile "oldnum" "")
(set_tile "newnum" newcolnr)
(set_tile "oldnum" oldcolnr)
)
(defun change_colors ()
(setq oldcolor (car (nth LST_ID lst)))
(setq newcolor (cadr (nth LST_ID lst)))
(draw_color oldcolor newcolor)
)
(defun get_color (/)
(setq vnewcolor newcolor)
(setq newcolor (acad_colordlg (fix (atof vnewcolor))))
(if (not newcolor)
(setq newcolor vnewcolor)
(progn (setq newcolor (rtos newcolor 2 0))
(setq oldnr (assoc oldcolor lst))
(setq vnewcolor newcolor
nlst nil
)
(setq lst (subst (list oldcolor newcolor) oldnr lst))
)
)
)
(defun err (s)
(if (not (member s '("console break" "Function cancelled")))
(princ (strcat "\nError: " s))
)
(setq *error* olderr)
(command "_UNDO" "_END")
(command "_U")
(command "_redraw")
(princ)
)
(defun dxf (code elist) (cdr (assoc code elist)))
(defun scan (/ rst l col)
(prompt "\nSCANNING DRAWING (This may take a while)")
(prompt "\nLAYERS...")
(setq lay_lst nil
rst T
)
(while (setq l (tblnext "LAYER" rst))
(setq col (dxf 62 l)
rst nil
)
(if (not (member (rtos col 2 0) lay_lst))
(setq lay_lst (cons (rtos col 2 0) lay_lst))
)
)
(princ "done.")
(setq sslst nil
ent_lst nil
blk_lst nil
lst nil
rst T
)
(prompt "\nBLOCKS...")
(while (setq blk (tblnext "BLOCK" rst))
(setq rst nil)
(setq nent (dxf -2 blk))
(while (setq nent (entnext nent))
(setq entl (entget nent))
(if (and (setq kleur (dxf 62 entl))
(/= kleur 0)
(/= (dxf 0 entl) "SEQEND")
)
(progn (setq kleur$ (rtos kleur 2 0))
(if (not (member kleur$ blk_lst))
(setq blk_lst (cons kleur$ blk_lst))
)
)
)
)
)
(princ "done.")
(prompt "\nENTITY...")
(if (setq ent (entnext))
(progn (setq el (entget ent))
(setq col (dxf 62 el))
(if col
(progn (setq col$ (rtos col 2 0))
(if (not (member col$ ent_lst))
(progn (setq ent_lst (cons col$ ent_lst))
(setq sslst
(cons (cons col (ssget "x" (list (cons 62 col))))
sslst
)
)
)
)
)
)
(setq nent ent)
(while (setq nent (entnext nent))
(setq el (entget nent))
(setq col (dxf 62 el))
(if col
(progn (setq col$ (rtos col 2 0))
(if (not (member col$ ent_lst))
(progn (setq ent_lst (cons col$ ent_lst))
(setq sslst
(cons (cons col (ssget "x" (list (cons 62 col))))
sslst
)
)
)
)
)
)
)
(princ "done.")
)
(setq ent_lst nil)
)
)
(prompt "Type CC to start.")

(defun c:cc (/ ent dcl_id) 
  (setq        olderr        *error* 
        *error*        err 
  ) 
  (setvar "CMDECHO" 0) 
  (if (not rescan) 
    (scan) 
  ) 
  (setq lst lay_lst) 
  (if blk_lst 
    (foreach x blk_lst 
      (if (not (member x lst)) 
        (setq lst (cons x lst)) 
      ) 
    ) 
  ) 
  (if ent_lst 
    (foreach x ent_lst 
      (if (not (member x lst)) 
        (setq lst (cons x lst)) 
      ) 
    ) 
  ) 
  (setq str_lst nil) 
  (foreach x lst 
    (setq chk$ x) 
    (if        (member x lay_lst) 
      (setq chk$ (strcat chk$ " L")) 
    ) 
    (if        (member x blk_lst) 
      (setq chk$ (strcat chk$ " B")) 
    ) 
    (if        (member x ent_lst) 
      (setq chk$ (strcat chk$ " E")) 
    ) 
    (setq str_lst (cons chk$ str_lst)) 
  ) 
  (setq str_lst (reverse str_lst)) 
  (setq nlst nil) 
  (foreach x lst (setq nlst (cons (list x x) nlst))) 
  (setq nlst (reverse nlst)) 
  (setq lst nlst) 
  (if lst 
    (progn 
      (if (> (setq dcl_id (load_dialog "cc.dcl")) 0) 
        (progn (setq LST_ID 0) 
               (setq oldcolor (car (nth LST_ID lst))) 
               (setq newcolor (cadr (nth LST_ID lst))) 
               (if (not (new_dialog "color" dcl_id)) 
                 (exit) 
               ) 
               (upd_lstbox "LST_BOX" lst) 
               (action_tile 
                 "LST_BOX" 
                 "(setq LST_ID (fix (atof $value))) (change_colors) " 
               ) 
               (action_tile "new_col" "(get_color) (change_colors)") 
               (action_tile "accept" "(done_dialog 1)") 
               (action_tile "cancel" "(done_dialog)") 
               (action_tile "LOAD" "(load_colors)") 
               (action_tile "SAVE" "(save_colors)") 
               (change_colors) 
               (setq start (start_dialog)) 
               (if (= start 1) 
                 (progn (setq rescan nil) (go_change)) 
                 (setq rescan T) 
               ) 
        ) 
        (prompt "\nDialoogbox not found.") 
      ) 
    ) 
    (alert "No entities in drawing.") 
  ) 
  (setq *error* olderr) 
  (princ) 
) 
(defun go_change (/ tel color1 color2 x ss _lst rst entl kleur nent) 
  (prompt "\nCHANGING COLORS") 
  (prompt "\nENTITIES...") 
  (command "_UNDO" "_G") 
  (foreach x lst 
    (if        (member (car x) ent_lst) 
      (progn (setq color1 (car x)) 
             (setq color2 (cadr x)) 
             (if (/= color1 color2) 
               (progn (prompt (strcat "\nChanging color " 
                                      color1               " to color " 
                                      color2               "." 
                                     ) 
                      ) 
                      (setq ss (cdr (assoc (fix (atof color1)) sslst))) 
                      (command "_CHPROP" ss "" "_COLOR" color2 "") 
               ) 
             ) 
      ) 
    ) 
  ) 
  (princ "done") 
  (prompt "\nBLOCKS...") 
  (setq _lst lst) 
  (foreach x _lst 
    (setq color1 (car x)) 
    (setq color2 (cadr x)) 
    (if        (and (member color1 blk_lst) (/= color1 color2)) 
      (progn 
        (setq rst 1) 
        (while (setq blk (tblnext "BLOCK" rst)) 
          (setq rst nil) 
          (setq ent (dxf -2 blk)) 
          (setq entl (entget ent)) 
          (setq        kleur (dxf 62 entl) 
                nent  ent 
          ) 
          (if (and kleur (= kleur (fix (atof color1)))) 
            (progn (setq entl (subst (cons 62 (fix (atof color2))) 
                                     (assoc 62 entl) 
                                     entl 
                              ) 
                   ) 
                   (entmod entl) 
            ) 
          ) 
          (while (setq nent (entnext nent)) 
            (if        (/= "SEQEND" (dxf 0 (setq entl (entget nent)))) 
              (progn (setq kleur (dxf 62 entl)) 
                     (if (and kleur (= kleur (fix (atof color1)))) 
                       (progn (setq entl (subst        (cons 62 (fix (atof color2))) 
                                                (assoc 62 entl) 
                                                entl 
                                         ) 
                              ) 
                              (entmod entl) 
                       ) 
                     ) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (princ "done") 
  (prompt "\nLAYERS...") 
  (foreach x lst 
    (setq color1 (car x)) 
    (setq color2 (cadr x)) 
    (setq rst T) 
    (if        (and (member color1 lay_lst) (/= color1 color2)) 
      (while (setq l (tblnext "LAYER" rst)) 
        (setq col    (rtos (dxf 62 l) 2 0) 
              $layer (dxf 2 l) 
              rst    nil 
        ) 
        (if (= col color1) 
          (command "_LAYER" "_COLOR" (fix (atof color2)) $layer "") 
        ) 
      ) 
    ) 
  ) 
  (princ "done.") 
  (command "_regen") 
  (command "_UNDO" "_END") 
  (initget "") 
  (command "_REDRAW") 
  (princ) 
) 
(defun upd_lstbox (k$ lst /) 
  (if lst 
    (progn (start_list k$) 
           (foreach x str_lst (add_list x)) 
           (end_list) 
    ) 
    (progn (start_list k$) (add_list "") (end_list)) 
  ) 
) 
(defun draw_color (oldcolnr newcolnr /) 
  (start_image "old_col") 
  (fill_image 
    0 
    0 
    (dimx_tile "old_col") 
    (dimy_tile "old_col") 
    (fix (atof oldcolnr)) 
  ) 
  (end_image) 
  (start_image "new_col") 
  (fill_image 
    0 
    0 
    (dimx_tile "new_col") 
    (dimy_tile "new_col") 
    (fix (atof newcolnr)) 
  ) 
  (end_image) 
  (set_tile "newnum" "") 
  (set_tile "oldnum" "") 
  (set_tile "newnum" newcolnr) 
  (set_tile "oldnum" oldcolnr) 
) 
(defun change_colors () 
  (setq oldcolor (car (nth LST_ID lst))) 
  (setq newcolor (cadr (nth LST_ID lst))) 
  (draw_color oldcolor newcolor) 
) 
(defun get_color (/) 
  (setq vnewcolor newcolor) 
  (setq newcolor (acad_colordlg (fix (atof vnewcolor)))) 
  (if (not newcolor) 
    (setq newcolor vnewcolor) 
    (progn (setq newcolor (rtos newcolor 2 0)) 
           (setq oldnr (assoc oldcolor lst)) 
           (setq vnewcolor newcolor 
                 nlst           nil 
           ) 
           (setq lst (subst (list oldcolor newcolor) oldnr lst)) 
    ) 
  ) 
) 
(defun err (s) 
  (if (not (member s '("console break" "Function cancelled"))) 
    (princ (strcat "\nError: " s)) 
  ) 
  (setq *error* olderr) 
  (command "_UNDO" "_END") 
  (command "_U") 
  (command "_redraw") 
  (princ) 
) 
(defun dxf (code elist) (cdr (assoc code elist))) 
(defun scan (/ rst l col) 
  (prompt "\nSCANNING DRAWING (This may take a while)") 
  (prompt "\nLAYERS...") 
  (setq        lay_lst        nil 
        rst T 
  ) 
  (while (setq l (tblnext "LAYER" rst)) 
    (setq col (dxf 62 l) 
          rst nil 
    ) 
    (if        (not (member (rtos col 2 0) lay_lst)) 
      (setq lay_lst (cons (rtos col 2 0) lay_lst)) 
    ) 
  ) 
  (princ "done.") 
  (setq        sslst nil 
        ent_lst        nil 
        blk_lst        nil 
        lst nil 
        rst T 
  ) 
  (prompt "\nBLOCKS...") 
  (while (setq blk (tblnext "BLOCK" rst)) 
    (setq rst nil) 
    (setq nent (dxf -2 blk)) 
    (while (setq nent (entnext nent)) 
      (setq entl (entget nent)) 
      (if (and (setq kleur (dxf 62 entl)) 
               (/= kleur 0) 
               (/= (dxf 0 entl) "SEQEND") 
          ) 
        (progn (setq kleur$ (rtos kleur 2 0)) 
               (if (not (member kleur$ blk_lst)) 
                 (setq blk_lst (cons kleur$ blk_lst)) 
               ) 
        ) 
      ) 
    ) 
  ) 
  (princ "done.") 
  (prompt "\nENTITY...") 
  (if (setq ent (entnext)) 
    (progn (setq el (entget ent)) 
           (setq col (dxf 62 el)) 
           (if col 
             (progn (setq col$ (rtos col 2 0)) 
                    (if        (not (member col$ ent_lst)) 
                      (progn (setq ent_lst (cons col$ ent_lst)) 
                             (setq sslst 
                                    (cons (cons col (ssget "x" (list (cons 62 col)))) 
                                          sslst 
                                    ) 
                             ) 
                      ) 
                    ) 
             ) 
           ) 
           (setq nent ent) 
           (while (setq nent (entnext nent)) 
             (setq el (entget nent)) 
             (setq col (dxf 62 el)) 
             (if col 
               (progn (setq col$ (rtos col 2 0)) 
                      (if (not (member col$ ent_lst)) 
                        (progn (setq ent_lst (cons col$ ent_lst)) 
                               (setq sslst 
                                      (cons (cons col (ssget "x" (list (cons 62 col)))) 
                                            sslst 
                                      ) 
                               ) 
                        ) 
                      ) 
               ) 
             ) 
           ) 
           (princ "done.") 
    ) 
    (setq ent_lst nil) 
  ) 
) 
(prompt "Type CC to start.")

xyz · 发表于 2003-5-15 14:39:15

dcl_settings : default_dcl_settings { audit_level = 3 ; }
color : dialog {
label = "COLOR-CONVERTER v1.1 (c) " ;
: row {
: column {
spacer_1 ;
: row {
: column {
children_alignment = centered ;
: text {
key = "txt1" ;
label = "OLD" ;
}
: image_button {
color = black ;
fixed_height = true ;
fixed_width = true ;
height = 4 ;
key = "old_col" ;
width = 10 ;
}
: text {
key = "oldnum" ;
label = "" ;
}
}
: list_box {
fixed_height = true ;
fixed_width = true ;
height = 6 ;
key = "LST_BOX" ;
label = "Colors:" ;
width = 12 ;
}
: column {
children_alignment = centered ;
: text {
key = "txt2" ;
label = "NEW" ;
}
: image_button {
color = black ;
fixed_height = true ;
fixed_width = true ;
height = 4 ;
key = "new_col" ;
width = 10 ;
}
: text {
key = "newnum" ;
label = "" ;
}
}
}
: row {
}
}
}
spacer_1 ;
ok_cancel ;
}

dcl_settings : default_dcl_settings { audit_level = 3 ; } 
color : dialog { 
   label = "COLOR-CONVERTER v1.1 (c) " ; 
   : row { 
      : column { 
         spacer_1 ; 
         : row { 
            : column { 
               children_alignment = centered ; 
               : text { 
                  key = "txt1" ; 
                  label = "OLD" ; 
               } 
               : image_button { 
                  color = black ; 
                  fixed_height = true ; 
                  fixed_width = true ; 
                  height = 4 ; 
                  key = "old_col" ; 
                  width = 10 ; 
               } 
               : text { 
                  key = "oldnum" ; 
                  label = "" ; 
               } 
            } 
            : list_box { 
              fixed_height = true ; 
              fixed_width = true ; 
              height = 6 ; 
              key = "LST_BOX" ; 
              label = "Colors:" ; 
              width = 12 ; 
            } 
            : column { 
               children_alignment = centered ; 
               : text { 
                  key = "txt2" ; 
                  label = "NEW" ; 
               } 
               : image_button { 
                  color = black ; 
                  fixed_height = true ; 
                  fixed_width = true ; 
                  height = 4 ; 
                  key = "new_col" ; 
                  width = 10 ; 
               } 
               : text { 
                  key = "newnum" ; 
                  label = "" ; 
               } 
 
            } 
         } 
         : row { 
         } 
      } 
   } 
   spacer_1 ; 
   ok_cancel ; 
}

xdcad9819 · 发表于 2020-1-17 19:24:13

SCANNING DRAWING (This may take a while)
LAYERS...done.
BLOCKS...done.
ENTITY...done.
Dialoogbox not found.
命令:

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

[LISP程序]：颜色转换工具

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

相关帖子

对话框