加入 Gitee
与超过 1200万 开发者一起发现、参与优秀开源项目,私有仓库也完全免费 :)
免费加入
文件
克隆/下载
dcl-utils.lsp 11.83 KB
一键复制 编辑 原始数据 按行查看 历史
;;;name:BF-dcl-Init
;;;desc:生成dcl文件,并load_dialog
;;;arg:title:对话框标题字符串
;;;arg:focus:对话框默认焦点控件
;;;arg:dclstr:对话框控件列表
;;;return:dcl文件名 dcl-id 点对表
;;;example:(BF-dcl-Init "ceshi" "hah2" f)
(defun BF-dcl-Init (title focus dclstr / dclfile)
(setq dclfile (vl-filename-mktemp "DclTemp.dcl"))
(BF-dcl-PrintDcl
(BF-dcl-setDialog
(strcat (vl-filename-base dclfile) ":dialog")
(list (cons 'label title)
(cons 'initial_focus focus))
dclstr
)
dclfile
)
(BF-return (cons dclfile (BF-dcl-getId dclfile)))
)
;;;name:BF-dcl-Start
;;;desc:dcl启动函数
;;;arg:dcl-id:dcl文件名 dcl-id 点对表
;;;arg:actionlist:由key action点对表组成的动作列表,可为nil
;;;arg:listbox:由key lst operation index表组成的listbox列表,可为nil
;;;arg:sldlist:由key sld表组成的sldlist列表,可为nil
;;;return:返回 done_dialog 函数的结束方式参数 status.
;;;example:(BF-dcl-Start)
(defun BF-dcl-Start (dcl-id actionlist)
(if (not (new_dialog (vl-filename-base (car dcl-id)) (cdr dcl-id)))
(exit)
)
(if (listp actionlist)
(mapcar
'(lambda (x / tmpx tmpy)
(setq tmpx (car x))
(setq tmpy (cdr x))
(cond
((and tmpx (= tmpx "set") tmpy) (BF-dcl-setValues tmpy))
((and tmpx (= tmpx "mode") tmpy) (BF-dcl-setModes tmpy))
((and tmpx (= tmpx "action") tmpy) (BF-dcl-setAction tmpy))
((and tmpx (= tmpx "list") tmpy)
(mapcar '(lambda (y) (apply 'BF-dcl-addlist y)) tmpy))
((and tmpx (= tmpx "image") tmpy)
(mapcar '(lambda (y)(apply 'BF-dcl-loadsld y)) tmpy))
)
)
actionlist
)
)
(BF-return (start_dialog))
)
;(
; ("set" ("ket" . "1")("qer" . "2"))
; ("mode" ("ket" . 1)("qer" . 0))
; ("action" ("buttonkey" "(func args) (func1 arg1 arg2) (done_dialog 4)") ("buttonkey1" "(func args) (func1 arg1 arg2) (done_dialog 2)"))
; ("list" ("lst1" (1 2 3 4)) ("lst3" (1 2 3 4)))
; ("image" ("img1" 2)("img2" 3))
;)
;;;name:BF-dcl-End
;;;desc:结束对话框
;;;arg:dclid:dcl文件名 dcl-id 点对表
;;;return:无
;;;example:(BF-dcl-End aa)
(defun BF-dcl-End (dclid)
(unload_dialog (cdr dclid))
(vl-file-delete (car dclid))
(setq *user-dclfile-dclid-list* (vl-remove dclid *user-dclfile-dclid-list*))
(princ)
)
;;;name:BF-dcl-setvalues
;;;desc:批量设置对话框控件的值
;;;arg:lst:key value 键值对表
;;;key 指定控件操作名的字符串。
;;;value 字符串,指定控件的新值(初始值由 value 属性设定)。
;;;return:属性值列表
;;;example:(BF-dcl-setvalues '(("ket" . "1")("qer" . "2")))
(defun BF-dcl-setValues (lst)
(mapcar
'set_tile
(mapcar 'car lst)
(mapcar
'(lambda (x / tmp)
(if (and (listp x)(= 'sym (type (car x))))
(setq tmp (eval x))
x
))
(mapcar 'cdr lst)))
)
;;;name:BF-dcl-setmodes
;;;desc:设置对话框控件的状态
;;;arg:lst:key mode 键值对表.mode可选项:
;;;0 启用控件。
;;;1 禁用控件。
;;;2 将控件设为焦点。
;;;3 选择编辑框内容。
;;;4 切换图像亮显。
;;;return:nil
;;;example:(BF-dcl-setmodes '(("ket" . 1)("qer" . 0)))
(defun BF-dcl-setModes (lst)
(mapcar 'mode_tile (mapcar 'car lst) (mapcar
'(lambda (x)
(if (and (listp x)(= 'sym (type (car x))))
(eval x)
x
))
(mapcar 'cdr lst)))
)
;;;name:BF-dcl-getvalues
;;;desc:获取对话框指定控件的当前运行时的值
;;;arg:lst:key列表或字符串
;;;return:控件值字符串表
;;;example:(BF-dcl-getvalues '("ket" "qer"))
(defun BF-dcl-getValues (lst)
(cond
((listp lst)(mapcar 'get_tile lst))
((= (type lst) 'str) (get_tile lst))
(t nil)
)
)
;;;name:BF-dcl-getattrs
;;;desc:获取对话框指定控件的某个属性值
;;;arg:lst:key attr键值对表
;;;return:字符串表,包含由 DCL 文件为该控件属性定义的初始值。
;;;example:(BF-dcl-getattrs '(("ket" . "label")("qer" . "label")))
(defun BF-dcl-getAttrs (lst)
(mapcar 'get_attr (mapcar 'car lst) (mapcar 'cdr lst))
)
;;;name:BF-dcl-setAction
;;;desc:为某一对话框控件指定一个动作表达式,用户在对话框中选中这个控件时,就会执行该动作表达式
;;;arg:lst:key 动作表达式键值对表
;;;return:
;;;example:(BF-dcl-setAction '(("buttonkey" "(func args) (func1 arg1 arg2) (done_dialog 4)") ...))
(defun BF-dcl-setAction (lst)
(if (listp lst)
;(mapcar 'action_tile (mapcar 'car lst) (mapcar 'cadr lst))
(mapcar
'(lambda (x)
(BF-CatchApply
'action_tile
(cons
(car x)
(list
(apply
'strcat
(mapcar 'vl-prin1-to-string (cdr x)))))))
lst)
)
)
;;;name:BF-dcl-setLayout
;;;desc:定义布局函数
;;;arg:layoutname:容器名称 - row column等
;;;arg:layoutlst:容器属性点对表,无则为nil
;;;arg:lst:控件列表
;;;return:布局表
;;;example:(BF-dcl-setLayout "column" '((key . "hah")(label . "hello")(width . 2)(action . "(hh)")) (list (BF-dcl-addItem "button" '((key . "hah")(label . "hello")(width . 2)(action . "(hh)")))))
(defun BF-dcl-setLayout (layoutname layoutlst lst)
(list (strcat ":" layoutname) (append (BF-dcl-listsplit layoutlst) (apply 'append lst)))
)
;;;名称:BF-dcl-setDialog
;;;说明:定义对话框函数
;;;参数:dialogname:对话框的标题
;;;参数:layoutlst:对话框的属性点对表,无则为nil
;;;参数:lst:控件列表
;;;返回:对话框表,共生成dcl文件使用
;;;示例:(BF-dcl-setDialog "123" nil (list a b))
(defun BF-dcl-setDialog (dialogname layoutlst lst)
(list dialogname (append (BF-dcl-listsplit layoutlst) (apply 'append lst)))
)
;;;name:BF-dcl-addItem
;;;desc:定义一个控件
;;;arg:itemname:控件名称
;;;arg:lst:定义控件属性的点对表
;;;return:控件表
;;;example:(BF-dcl-addItem "button" '((key . "hah")(label . "hello")(width . 2)(action . "(hh)")))
(defun BF-dcl-addItem (itemname lst)
(list (strcat ":" itemname) (BF-dcl-listsplit lst))
)
;;;name:BF-dcl-listsplit
;;;desc:控件属性表处理函数
;;;arg:lst:控件属性表
;;;return:处理后的符合dcl规范的表
;;;example:(BF-dcl-listsplit '((key . "hah")(label . "hello")(width . 2)(action . "(hh)")))
(defun BF-dcl-listsplit (lst)
(if (listp lst)
(mapcar
'(lambda (x / tmp)
(strcat
(strcase (vl-princ-to-string (car x)) t)
" = "
(if (BF-stringp (setq tmp (cdr x)))
(vl-prin1-to-string tmp)
(strcase (vl-prin1-to-string tmp) t)
)
";"))
lst))
)
;;;name:BF-dcl-PrintDcl
;;;desc:生成dcl文件
;;;arg:x:控件列表
;;;arg:f:dcl文件地址
;;;return:无
;;;example:(BF-dcl-PrintDcl a b)
(defun BF-dcl-PrintDcl (x f / _PrintItem _PrintList _Main file)
(defun _PrintItem (_PrintMethod item indents)
(cond
(item
(princ "\n" file)
(repeat indents (princ " " file))
(_PrintMethod item file)
)
((princ " { }" file))
)
(princ)
)
(defun _PrintList (_PrintMethod lst indents)
(if (< -1 indents)
(_PrintItem _PrintMethod "{" indents)
)
((lambda (i) (foreach x lst (_Main x i))) (1+ indents))
(if (< -1 indents)
(_PrintItem _PrintMethod "}" indents)
(princ)
)
)
(defun _Main (x indents)
(if (vl-consp x)
(if ((lambda (x) (and x (atom x))) (cdr x))
(_PrintItem princ x indents)
(_PrintList princ x indents)
)
(_PrintItem princ x indents)
)
)
(cond
((setq file (open f "w"))
(_Main x -1)
(close file)
;(startapp "notepad" f)
)
)
)
;;;name:BF-dcl-addlist
;;;desc:添加列表数据
;;;arg:key:列表框key
;;;arg:lst:数据列表
;;;arg:operation:整数,指定要执行的列表操作的类型。可以指定下列值之一:
;;;1 修改选定列表的内容
;;;2 附加新的列表项
;;;3 删除旧列表,创建新列表(缺省设置)
;;;arg:index:整数,指定后续 add_list 调用要修改的列表项。
;;;列表中的第一项序号为 0。如果未指定该参数,则 index 的缺省值为 0。
;;;如果 start_list 不执行修改操作,则忽略 index 参数。
;;;operation index 如果不指定则为 nil
;;;return:无
;;;example:(BF-dcl-addlist "lst1" '(1 2 3 4) nil nil)
(defun BF-dcl-addlist (key lst)
;(cond
; ((and (null operation) (null index))
; (start_list key)
; )
; ((and (null index) operation)
; (start_list key operation)
; )
; (t (start_list key operation index))
;)
(if (= 'sym (type (car lst)))
(setq lst (eval lst))
)
(start_list key)
(mapcar 'add_list (mapcar 'vl-princ-to-string lst))
(end_list)
)
;;;name:BF-dcl-loadsld
;;;desc:加载幻灯片 by fsxm
;;;arg:key:图像或图像按钮key
;;;arg:sld:幻灯片或颜色代码
;;;return:无
;;;example:(BF-dcl-loadsld "img1" 2)
(defun BF-dcl-loadsld (key sld / x y)
(setq x (dimx_tile key))
(setq y (dimy_tile key))
(start_image key)
(cond((numberp sld) (fill_image 0 0 x y sld))
(t
(fill_image 0 0 x y -2)
(slide_image 0 0 x y sld)
)
)
(end_image)
)
;;;name:BF-dcl-checknumber
;;;desc:检查数字的合法性
;;;arg:value:数字字符串
;;;arg:error_msg:错误信息字符串
;;;arg:range:模式代码:
;;;0 - 允许任何数字
;;;1 - 拒绝正数
;;;2 - 拒绝负数
;;;4 - 拒绝0
;;;return:如果数字满足要求,返回数字,否则在对话框显示错误信息
;;;example:(BF-dcl-checknumber "123" "输入的为负数!" 2)
(defun BF-dcl-checkNumber (value error_msg range / good_value)
(cond
;; is it a number
((not (setq good_value (distof value)))
(set_tile "error" error_msg)
nil
)
;; is it positive
((and (= 1 (logand 1 range))
(= (abs good_value) good_value)
)
(set_tile "error" error_msg)
nil
)
;; is it zero
((and (= 2 (logand 2 range))
(= 0.0 good_value)
)
(set_tile "error" error_msg)
nil
)
;; is it negative
((and (= 4 (logand 4 range))
(/= (abs good_value) good_value)
)
(set_tile "error" error_msg)
nil
)
(T good_value)
)
)
;;;name:BF-dcl-checkAngle
;;;desc:检查是否是角度
;;;arg:value:角度字符串
;;;arg:error_msg:错误信息
;;;return:如果满足要求,返回弧度数字,否则在对话框显示错误信息
;;;example:(BF-dcl-checkAngle "24%%D")
(defun BF-dcl-checkAngle(value error_msg / good_value)
(cond
((and (setq good_value (angtof value))
)
(set_tile "error" "")
(atof (angtos good_value))
)
(T (set_tile "error" error_msg) nil)
)
)
;;;name:BF-dcl-getId
;;;desc:获取dcl-id
;;;arg:dcl_file:dcl文件名,不在cad支持目录下,则提供全路径
;;;return:如果找不到文件或不能加载则返回nil,反之返回dcl-id
;;;example:(BF-dcl-getId "test.dcl")
(defun BF-dcl-getId (dcl_file / dcl_handle)
(cond
;;如果已经打开dcl文件,就返回dcl文件句柄
((BF-return (cdr (assoc dcl_file *user-dclfile-dclid-list*))))
;; 如果没有找到dcl文件,就弹出对话框,并返回nil
((not (findfile dcl_file))
(alert
(strcat
"未找到对话框定义文件 " dcl_file
".dcl\n请检查支持目录。"))
(BF-return nil)
)
;; 找到文件,如果加载不成功,弹出对话框,返回nil
((or (not (setq dcl_handle (load_dialog dcl_file)))
(> 1 dcl_handle))
(alert
(strcat
"无法加载对话框控制文件 " dcl_file
"\n请检查支持目录。"))
(BF-return nil)
)
;; 找到文件,并且加载成功,将文件名和句柄组成点对标存放在常量中,并返回句柄
(t (setq *user-dclfile-dclid-list*
(BF-AssocList-AddItem *user-dclfile-dclid-list* (cons dcl_file dcl_handle)))
(BF-return dcl_handle)
)
)
)
;;;name:BF-dcl-listbox
;;;desc:列表框对话框控件
;;;arg:title:对话框标题
;;;arg:msg:提示字符串
;;;arg:lst:数据列表
;;;return:成功返回选择的字串列表,否则返回nil
;;;example:(BF-dcl-listbox "选择图层" "图层列表" '("1" "2" "3" "4" "5" "6"))
(defun BF-dcl-listbox (title msg lst / dcl-id dialog listbox sublistbox)
(defun sublistbox (value)
(mapcar '(lambda (x) (nth x lst)) (mapcar 'atoi (BF-str->lst value " ")))
)
(setq listbox (BF-dcl-addItem "list_box" (list '("key" . "lst1") (cons "label" msg) '("multiple_select" . true))))
(setq dcl-id (BF-dcl-Init title nil (list listbox (list "ok_cancel;"))))
(BF-dcl-Start
dcl-id
(list
;'("set" nil)
;'("mode" nil )
'("action" ("lst1" "(setq result (sublistbox $value))"))
(list "list" (list "lst1" lst) )
;'("image" nil)
)
)
(BF-dcl-End dcl-id)
result
)
马建仓 AI 助手
尝试更多
代码解读
代码找茬
代码优化