选项勾选，打钩打岔

dcl1214 · 发表于 2021-2-14 16:24:16

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

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

×

本帖最后由 dcl1214 于 2021-2-14 16:28 编辑

经常会遇到让用户勾选的情况，我包装了一个方法，分享给大家，传入参数支持3种

(defun $op-check$ (tiles dclname lst / *error*
dcl_id dcl-f dialog f keys
rows startnum tiles-key tmp_f
tmp_lst
)
;选项打钩，选项勾选
(defun *error* (s)
(if (and (= dialog 1) (< dialog 2))
(repeat 10
(print
"可能是因为传入的列表行数列数没整理好导致界面超出显示器分辨率"
)
)
(print s)
)
)
(defun _sensor:lst->dat (filename data extension lst / file)
;写对话框文件
(if (not filename)
(setq filename (getfiled "Create Output File" "" extension 1))
)
(if (setq file (open filename "w"))
(progn
(cond ((= (type data) 'STR)
(write-line data file)
)
((= (type data) 'LIST)
(foreach line data
(write-line line file)
)
)
)
(close file)
filename
)
nil
)
)
(defun $yi-dui-shu-zi$ (len / ss i)
;返回从数字0开始的一堆list数据
(if (and len (= (type len) 'int))
(progn
(setq ss nil)
(setq i 0)
(while (< i len) (setq ss (cons i ss)) (setq i (1+ i)))
(setq ss (reverse ss))
)
)
ss
)
(cond ((and tiles
(= (type tiles) 'list)
(= (type (car tiles)) 'list)
(= (type (car (car tiles))) 'list)
(member (cdr (car (car tiles))) (list '"0" '"1"))
)
nil
)
((and tiles
(= (type tiles) 'list)
(= (type (car tiles)) 'list)
(= (type (car (car tiles))) 'str)
(member (cdr (car tiles)) (list '"0" '"1"))
)
(setq tiles (list tiles))
)
((and tiles
(= (type tiles) 'list)
(= (type (car tiles)) 'str)
)
(setq tiles
(mapcar (function
(lambda (a)
(mapcar (function (lambda (b) (cons b "0"))) a)
)
)
(list tiles)
)
)
)
)
(setq tiles-key
(mapcar
(function
(lambda (r ir)
(mapcar
(function
(lambda (a ic / k str)
(setq k (strcat "r" (vl-princ-to-string ir)))
(setq k (strcat k "c" (vl-princ-to-string ic)))
(setq
str (strcat ":toggle {"
(strcat "key = \"" k "\" ;")
(strcat "label = \"" (car a) "\" ;")
(strcat "value = " (cdr a) " ;")
"width = 20 ;"
"vertical_margin = none ;"
"horizontal_margin = none ;"
"}"
)
)
(list (cons "字段" (car a))
(cons "key" k)
(cons "str" str)
)
)
)
r
(mapcar '1+ ($yi-dui-shu-zi$ (length r)))
)
)
)
tiles
(mapcar '1+ ($yi-dui-shu-zi$ (length tiles)))
)
)
(setq
keys
(mapcar
(function
(lambda (a)
(mapcar (function (lambda (b) (cdr (assoc "key" b)))) a)
)
)
tiles-key
)
)
(setq keys (apply 'append keys))
(setq
rows
(mapcar
(function
(lambda (a)
(mapcar (function (lambda (b) (cdr (assoc "str" b)))) a)
)
)
tiles-key
)
)
(setq
rows (mapcar
(function
(lambda (a / str)
(setq str (apply 'strcat a))
(setq str (strcat ":row {" str "}"))
(setq str
(strcat
str
":spacer {fixed_height = true ;height = 0.5 ;vertical_margin = none ;horizontal_margin = none ;}"
)
)
str
)
)
rows
)
)
(setq rows
(append
(list "op:dialog {key = \"op\" ;label = \"请选择\" ;")
(list
":spacer {fixed_height = true ;height = 0.2 ;vertical_margin = none ;horizontal_margin = none ;}"
)
rows
(list
":button {is_cancel = true ;key = \"tc\" ;label = \"确定\" ;vertical_margin = none ;horizontal_margin = none ;}"
)
(list "vertical_margin = none ;horizontal_margin = none ;}")
)
)
(setq tmp_lst rows)
(or dclname (setq dclname "op"))
(if (and dclname tiles)
(progn
(setq
f (strcat (vl-filename-directory (vl-filename-mktemp)) "\\")
)
(and (setq tmp_f (strcat f dclname ".dcl")))
(if (and tmp_f (findfile tmp_f))
(vl-file-delete tmp_f)
)
(setq dcl-f (_sensor:lst->dat tmp_f tmp_lst T NIL))
(and dcl-f (setq dcl_id (load_dialog dcl-f)))
(if dcl_id
(progn
(setq dialog 1)
(and dcl_id (new_dialog "op" dcl_id))
(setq dialog 2)
(ACTION_TILE
"tc"
"(PROGN(setq keys-gou(mapcar(function(lambda(a)(cons a(get_tile a))))keys))(done_dialog 0))"
)
(setq startNum (start_dialog))
(and dcl_id (unload_dialog dcl_id))
)
)
)
)
(mapcar
(function
(lambda (a)
(mapcar (function (lambda (b / tag key v)
(setq tag (cdr (assoc "字段" b)))
(setq key (cdr (assoc "key" b)))
(setq v (vl-some (function (lambda (c)
(if (= (car c) key)
(cdr c)
)
)
)
keys-gou
)
)
(or v (setq v "0"))
(cons tag v)
)
)
a
)
)
)
tiles-key
)
);调用示例
(setq tiles (list (list (cons "编码" "1")
(cons "名称" "0")
(cons "供应商" "1")
(cons "CAD前视图祖玛" "0")
)
(list (cons "孔位数" "1")
(cons "颜色" "0")
(cons "尺寸" "0")
(cons "备注" "0")
)
)
)
($op-check$ tiles nil nil)

(defun $op-check$ (tiles    dclname  lst      /         *error* 
       dcl_id   dcl-f    dialog   f         keys 
       rows      startnum tiles-key         tmp_f 
       tmp_lst 
      ) 
          ;选项打钩，选项勾选 
  (defun *error* (s) 
    (if  (and (= dialog 1) (< dialog 2)) 
      (repeat 10 
  (print 
    "可能是因为传入的列表行数列数没整理好导致界面超出显示器分辨率" 
  ) 
      ) 
      (print s) 
    ) 
  ) 
  (defun _sensor:lst->dat (filename data extension lst / file) 
  ;写对话框文件 
      (if (not filename) 
  (setq filename (getfiled "Create Output File" "" extension 1)) 
      ) 
      (if (setq file (open filename "w")) 
  (progn 
    (cond  ((= (type data) 'STR) 
     (write-line data file) 
    ) 
    ((= (type data) 'LIST) 
     (foreach line data 
       (write-line line file) 
     ) 
    ) 
    ) 
    (close file) 
    filename 
  ) 
  nil 
      ) 
    ) 
  (defun $yi-dui-shu-zi$ (len / ss i) 
          ;返回从数字0开始的一堆list数据 
    (if  (and len (= (type len) 'int)) 
      (progn 
  (setq ss nil) 
  (setq i 0) 
  (while (
  (setq ss (reverse ss)) 
      ) 
    ) 
    ss 
  ) 
  (cond  ((and tiles 
        (= (type tiles) 'list) 
        (= (type (car tiles)) 'list) 
        (= (type (car (car tiles))) 'list) 
        (member (cdr (car (car tiles))) (list '"0" '"1")) 
   ) 
   nil 
  ) 
  ((and tiles 
        (= (type tiles) 'list) 
        (= (type (car tiles)) 'list) 
        (= (type (car (car tiles))) 'str) 
        (member (cdr (car tiles)) (list '"0" '"1")) 
   ) 
   (setq tiles (list tiles)) 
  ) 
  ((and tiles 
        (= (type tiles) 'list) 
        (= (type (car tiles)) 'str) 
   ) 
   (setq tiles 
    (mapcar  (function 
        (lambda (a) 
          (mapcar (function (lambda (b) (cons b "0"))) a) 
        ) 
      ) 
      (list tiles) 
    ) 
   ) 
  ) 
  ) 
  (setq  tiles-key 
   (mapcar 
     (function 
       (lambda (r ir) 
         (mapcar 
     (function 
       (lambda (a ic / k str) 
         (setq k (strcat "r" (vl-princ-to-string ir))) 
         (setq k (strcat k "c" (vl-princ-to-string ic))) 
         (setq 
           str (strcat ":toggle {" 
           (strcat "key = \"" k "\" ;") 
           (strcat "label = \"" (car a) "\" ;") 
           (strcat "value = " (cdr a) " ;") 
           "width = 20 ;" 
           "vertical_margin = none ;" 
           "horizontal_margin = none ;" 
           "}" 
         ) 
         ) 
         (list (cons "字段" (car a)) 
         (cons "key" k) 
         (cons "str" str) 
         ) 
       ) 
     ) 
     r 
     (mapcar '1+ ($yi-dui-shu-zi$ (length r))) 
         ) 
       ) 
     ) 
     tiles 
     (mapcar '1+ ($yi-dui-shu-zi$ (length tiles))) 
   ) 
  ) 
  (setq 
    keys 
     (mapcar 
       (function 
   (lambda (a) 
     (mapcar (function (lambda (b) (cdr (assoc "key" b)))) a) 
   ) 
       ) 
       tiles-key 
     ) 
  ) 
  (setq keys (apply 'append keys)) 
  (setq 
    rows 
     (mapcar 
       (function 
   (lambda (a) 
     (mapcar (function (lambda (b) (cdr (assoc "str" b)))) a) 
   ) 
       ) 
       tiles-key 
     ) 
  ) 
  (setq 
    rows (mapcar 
     (function 
       (lambda (a / str) 
         (setq str (apply 'strcat a)) 
         (setq str (strcat ":row {" str "}")) 
         (setq str 
          (strcat 
      str 
      ":spacer {fixed_height = true ;height = 0.5 ;vertical_margin = none ;horizontal_margin = none ;}" 
          ) 
         ) 
         str 
       ) 
     ) 
     rows 
   ) 
  ) 
  (setq  rows 
   (append 
     (list "op:dialog {key = \"op\" ;label = \"请选择\" ;") 
     (list 
       ":spacer {fixed_height = true ;height = 0.2 ;vertical_margin = none ;horizontal_margin = none ;}" 
     ) 
     rows 
     (list 
       ":button {is_cancel = true ;key = \"tc\" ;label = \"确定\" ;vertical_margin = none ;horizontal_margin = none ;}" 
     ) 
     (list "vertical_margin = none ;horizontal_margin = none ;}") 
   ) 
  ) 
  (setq tmp_lst rows) 
  (or dclname (setq dclname "op")) 
  (if (and dclname tiles) 
    (progn 
      (setq 
  f (strcat (vl-filename-directory (vl-filename-mktemp)) "\\") 
      ) 
      (and (setq tmp_f (strcat f dclname ".dcl"))) 
      (if (and tmp_f (findfile tmp_f)) 
  (vl-file-delete tmp_f) 
      ) 
      (setq dcl-f (_sensor:lst->dat tmp_f tmp_lst T NIL)) 
      (and dcl-f (setq dcl_id (load_dialog dcl-f))) 
      (if dcl_id 
  (progn 
    (setq dialog 1) 
    (and dcl_id (new_dialog "op" dcl_id)) 
    (setq dialog 2) 
    (ACTION_TILE 
      "tc" 
      "(PROGN(setq keys-gou(mapcar(function(lambda(a)(cons a(get_tile a))))keys))(done_dialog 0))" 
    ) 
    (setq startNum (start_dialog)) 
    (and dcl_id (unload_dialog dcl_id)) 
  ) 
      ) 
    ) 
  ) 
  (mapcar 
    (function 
      (lambda (a) 
  (mapcar  (function (lambda (b / tag key v) 
          (setq tag (cdr (assoc "字段" b))) 
          (setq key (cdr (assoc "key" b))) 
          (setq v (vl-some (function (lambda (c) 
               (if (= (car c) key) 
                 (cdr c) 
               ) 
                   ) 
               ) 
               keys-gou 
            ) 
          ) 
          (or v (setq v "0")) 
          (cons tag v) 
        ) 
    ) 
    a 
  ) 
      ) 
    ) 
    tiles-key 
  ) 
);调用示例 
(setq tiles (list (list  (cons "编码" "1") 
      (cons "名称" "0") 
      (cons "供应商" "1") 
      (cons "CAD前视图祖玛" "0") 
      ) 
      (list  (cons "孔位数" "1") 
      (cons "颜色" "0") 
      (cons "尺寸" "0") 
      (cons "备注" "0") 
      ) 
      ) 
) 
($op-check$ tiles nil nil)

登录/注册后可看大图

/db_自贡黄明儒_ · 发表于 2021-2-14 18:33:54

你这个看起来复杂了，我现在采用highflybird的办法:先规划好各Key，像button这种不需要写在一起，其它需要保存的写在一起，便于用repeat等一次处理。

xk15c · 发表于 2021-2-16 01:28:22

这个实用，真不错

kmliro_2017 · 发表于 2021-2-16 10:14:56

谢谢分享！！！！

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

[源码] 选项勾选，打钩打岔

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