我编写DCL的方法
本帖最后由 自贡黄明儒 于 2022-12-29 07:20 编辑学习了 baitang36 一键合并DCL和LSP文件，我谈谈自己编写DCL的方法，供大家参考。
《操作对话框》
第一步，用vlide编写DCL
第二步，用命令dcl2lsp转成lisp文件
第三步，写(getdata) (setdata)(do3) 和主函数(do1)
大功告成！
下面是我用的dcl2lsp
;;===========2014.12.24==================DCL文件转成需要的.lsp
(defun c:dcl2lsp (/ DCLNAME FN1 FN1L FN2 FN2L FNAME1 FNAME2 INITDIR K)
(setq fname1 (getfiled "***选择DCL文件***" "" "dcl" 16))
(setq Initdir (strcat (vl-filename-directory fname1) "\\22"))
(setq fn1 (open fname1 "r"))
(setq fname2 (getfiled "***Lisp文件保存到***" Initdir "lsp" 1))
(setq fn2 (open fname2 "w"))
(write-line "(defun dialog ()" fn2)
(write-line "(setq fname (vl-filename-mktemp nil nil \".dcl\"))"
fn2
)
(write-line "(setq fn (open fname \"w\"))" fn2)
(while (setq fn1l (read-line fn1))
(if(wcmatch fn1l "*:*dialog*")
(setq DCLName (VL-STRING-TRIM " " (car (parse3 fn1l "[^:]+"))))
)
(setq fn2l (strcat "(write-line " (VL-PRIN1-TO-STRING fn1l) " fn)"))
(write-line fn2l fn2)
)
(close fn1)
(write-line "(close fn)" fn2)
(write-line "" fn2)
(write-line "(setq dclid (load_dialog fname))" fn2)
(write-line ";;如果不循环，去掉下面123" fn2)
(write-line "(setq return# 3);1" fn2)
(write-line "(while (> return# 2);2" fn2)
(write-line (strcat "(new_dialog \"" DCLName "\" dclid)") fn2)
(write-line "(setdata)" fn2)
(write-line "(action_tile \"accept\" \"(getdata)(done_dialog 1)\")"
fn2
)
(write-line "(setq return# (start_dialog))" fn2)
(write-line "(cond ((equal return# 3) (do3)));3" fn2)
(write-line ")" fn2)
(write-line "(unload_dialog dclid)" fn2)
(write-line "(vl-file-delete fname)" fn2)
(write-line "(cond ((equal return# 1) (do1)))" fn2)
(write-line ")" fn2)
(close fn2)
(princ"\n dcl2lsp")
(princ)
)
;;===========2014.12.24==================DCL文件转成需要的.lsp
接着黄大师的话题，我也说说我是怎么写DCL的：
实际上很长时间以来，我是很不愿意去写DCL的，因为手工写DCL，出错是个必然，而且出错的位置不少。
在刚开始能上网的1998年左右，我找来了一个老外写的创建DCL的辅助LISP工具，DCG （加了点密）。
后来发现他不支持Windows 95开始的长文件名，我就解密后做了相关的修正，后来一直使用这个改版DCG创建DCL，效果和效率都很不错。
一直到本坛大神飞诗发布了DCL编辑器，这个确实是我所用过的多种DCL创建工具中的王者！有了这个工具，DCL再也不是问题了，把我之前多年以来用惯的DCG都彻底下班了。
不过这时候DCL是个单独的文件，有需要时打包到vlx里。没有代码化和动态创建DCL。
代码化和动态创建DCL，有个前提就是需要有一个解析函数，能对飞诗创建出的DCL数据（注意是数据，不是DCL文件）做解析，读入数据，函数返回DCL文本的行内容list数据，最后动态写出DCL文件。
然后就是设计这个解析函数，并编码，调试，测试，改进...最后这个函数ok了，现在我只需要在飞诗DCL Editor中设计好对话框，生成dcl数据文件，复制其中数据到 lisp 文件中简单变量赋值即可。其他的LISP中都是固定代码和套路。 补个函数，防小白迷路
(defun xty-str-substall ( new old str / inc len )
(setq len (strlen new)
inc 0
)
(while (setq inc (vl-string-search old str inc))
(setq str (vl-string-subst new old str inc)
inc (+ inc len)
)
)
str
) 用命令dcl2lsp ，将<MyI 指定距离插入块.dcl>转成lisp,大致模样如下：
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;离曲线d 插入块
;;164.23 [功能] 多段线所击点离起点近
;;示例(HH:PickToStart (car(setq en(entsel))) (cadr en))
(defun HH:PickToStart (curve p / L1 L2 PP)
(setq pp (vlax-curve-getclosestpointto curve (trans p 1 0)))
(setq L2 (vlax-curve-getDistAtParam curve
(vlax-curve-getEndParam curve)
)
)
(setq L1 (vlax-curve-getDistAtPoint curve pp))
(> (- L2 L1) L1)
)
(defun C:MyI (/ DIALOG DO1 DO3 PICK SETDATA GETDATA _HH:MYI _HH:MYI2 DO ANG ANGB BETWEEN D DCLDATA DCLID E ECURVE EN FLAG FN FNAME KEY1 KEY2 KEY3 KEY4 KEY5 KEY6 KEY7 KEY8 L P PARAM PRCS RETURN# X)
(defun do (d L)
(if (<= d L)
(if Flag
(_HH:MyI2 d)
(_HH:MyI2 (- L d))
)
)
)
;;在曲线d处插入块
(defun _HH:MyI2 (d)
(princ)
)
;;e曲线 (setq key2 "235*2 200*2,20+50") key1 块名 key6为"1"时屏幕上旋转 key8镜向
(defun _HH:MyI ()
(princ)
)
(defun getdata (/ DCLDATA I KEY)
(setq i 0)
(repeat 8 ;"key1"到"key8"
(setq i (1+ i))
(setq key (strcat "key" (itoa i)))
(set (read key) (get_tile key))
(setq DCLData (cons (cons key (eval (read key))) DCLData))
)
(setenv "DDJJB\\MyI" (VL-PRIN1-TO-STRING DCLData))
)
(defun setdata (/ DCLDATA X)
(cond ((setq DCLData (getenv "DDJJB\\MyI"))
(setq DCLData (read DCLData))
(mapcar '(lambda (x) (Set_tile (car x) (cdr x))) DCLData)
(if (= (cdr (assoc "key6" DCLData)) "1")
(mode_tile "key7" 1) ;1灰色
)
)
)
)
(defun pick ()
(if (= key6 "1")
(mode_tile "key7" 1)
(mode_tile "key7" 0) ;0可用 1灰色 2聚焦
)
)
;;拾取块名
(defun do3 (/ e)
(setq e (LM:ssget "\n 点取文字、者块"
'("_+.:E:S" ((0 . "INSERT")))
)
)
(if e
(progn
(setq e (ssname e 0))
(setq en (entget e))
(setq key1 (cdr (assoc 2 en)))
(if (setq DCLData (getenv "DDJJB\\MyI"))
(progn
(setq DCLData (read DCLData))
(setq DCLData (subst (cons "key1" key1) (assoc "key1" DCLData) DCLData))
)
(setq DCLData (cons (cons "key1" key1) DCLData))
)
(setenv "DDJJB\\MyI" (VL-PRIN1-TO-STRING DCLData))
)
)
)
;;主程序
(defun do1 ()
(vl-load-com)
((if command-s
command-s
vl-cmdf
) "_.ucs"
""
)
(setvar "INSUNITS" 0) ;设置为无单位缩放
(ACET-UNDO-BEGIN)
(vl-catch-all-apply '_StartOsmode nil) ;捕捉开始 ;关闭捕捉.
(if (and (tblobjname "BLOCK" key1)
(setq e (nentsel "\n 点取曲线:"))
)
(_HH:MyI)
(alert (strcat "块" key1 "不存在!..."))
)
(vl-catch-all-apply '_EndOsmode nil) ;捕捉结束 ;打开捕捉.
(ACET-UNDO-END)
(gc)
)
(defun dialog ()
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(write-line "MyIdialog:dialog{label=\"离线端头插入块\";" fn)
(write-line " :boxed_row{label=\"块名\";" fn)
(write-line " :edit_box{key=\"key1\";}" fn)
(write-line " :button{key=\"key11\";label=\"&Pick<<\";}"
fn
)
(write-line "}" fn)
(write-line " :boxed_column{" fn)
(write-line ":text{key=\"key12\";value=\"示例：235*2 200*2,20+50\";}"
fn
)
(write-line ":edit_box{label=\"距离\";key=\"key2\";value=\"0\";}"
fn
)
(write-line " }" fn)
(write-line " :edit_box{label=\"X比例\";key=\"key3\";value=\"1\";}"
fn
)
(write-line " :edit_box{label=\"Y比例\";key=\"key4\";value=\"1\";}"
fn
)
(write-line " :edit_box{label=\"Z比例\";key=\"key5\";value=\"1\";}"
fn
)
(write-line " :boxed_row{label=\"旋转\";" fn)
(write-line " :toggle{key=\"key6\";label=\"在屏幕上指定\";value=\"1\";}"
fn
)
(write-line " :edit_box{key=\"key7\";label=\"角度\";value=\"0\";}"
fn
)
(write-line "}" fn)
(write-line " :toggle{label=\"镜向\";key=\"key8\";value=\"0\";}"
fn
)
(write-line " ok_cancel;" fn)
(write-line "}" fn)
(close fn)
)
(dialog)
(setq dclid (load_dialog fname))
(setq return# 3)
(while (> return# 2)
(new_dialog "MyIdialog" dclid)
(setdata)
(action_tile "key6" "(setq key6 $value)(pick)")
(action_tile "key11" "(getdata)(done_dialog 3)")
(mode_tile "key2" 2) ;聚焦
(action_tile "accept" "(getdata)(done_dialog 1)")
(setq return# (start_dialog))
(cond ((equal return# 3) (do3)))
)
(unload_dialog dclid)
(vl-file-delete fname)
(cond ((equal return# 1) (do1)))
(princ "\n 插入块 MyI SM")
(princ)
)
(princ "\n 插入块 MyI SM")
(princ)
;;离曲线d 插入块
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
对话框中"key1"到"key8"，连续编号。。。。
我就喜欢手写DCL
最主要的原因
我需要精细调整控件的位置
属于特殊强迫症
没办法
这用DCG做起来也没方便多少
飞诗体验过没深入使用
感觉还没有DCG方便
最后
非常不喜欢dcl2lsp的方式
主要还是隔上一段时间
就忍不住要动动自己那些程序
加几个或固定或临时的功能 对于 (getdata) (setdata)如何写呢？
我觉得采用highflybird大师的办法，先将edit_box toggle list_box....的key连续编号，以便于保存和获取
如
(defun getdata (/ DCLDATA I KEY)
(setq i 0)
(repeat 5 ;"key1"到"key5"
(setq i (1+ i))
(setq key (strcat "Key" (itoa i)))
(set (read key) (get_tile key))
(setq DCLData (cons (cons key (eval (read key))) DCLData))
)
(Setenv "MyD" (VL-PRIN1-TO-STRING DCLData))
)
(defun setdata (/ DCLDATA X)
(cond ((setq DCLData (getenv "MyD"))
(setq DCLData (read DCLData))
(mapcar '(lambda (x) (Set_tile (car x) (cdr x))) DCLData)
)
)
) 本帖最后由 magicheno 于 2022-12-28 16:53 编辑
感谢大佬分享~方便举个完整的例子不 我觉得已经非常完美了，很有价值的代码，希望楼主补全一个例子，学习了 谢谢楼主分享 学习到了新方法，谢谢，再举个例子吧 本帖最后由 x_s_s_1 于 2022-12-29 09:08 编辑
贴个自己常用的，没有老黄的直接，仅针对DCL，没考虑控制。
;;;=============================================
;;; 通用函数文本转为LIST复制到剪贴板
;;;参数： file------文件
;;; name------表名
;;;返回值：nil
(defun xty-sys-copyclipdcl (file name / rf str html t1)
(setq rf (open file "r"))
(setq str (strcat "(setq " name "'(\n"))
(while (setq t1 (read-line rf))
(setq
str (strcat str "\"" (xty-str-substall "\\\"" "\"" t1) "\"\n")
)
)
(setq str (strcat str ")\n)"))
(setq HTML (vlax-create-object "htmlfile"))
(vlax-invoke
(vlax-get (vlax-get HTML 'PARENTWINDOW) 'CLIPBOARDDATA)
'SETDATA
"Text"
str
)
(vlax-release-object HTML)
(close rf)
)
;;;=============================================
;;; 通用函数写字符串表到文件
;;;参数：filename----文件名
;;; strlst------需写入文件字符串表
;;;返回值：文件名
(defun xty-sys-makeFbylst (filename strlst / f n)
(setq f (open filename "w"))
(foreach n strlst
(if(eq (type n) 'STR)
(write-line n f)
(write-line (vl-princ-to-string n) f)
)
)
(close f)
filename
)
(xty-sys-copyclipdcl (getfiled "dcl" "" "dcl" 16) "dcllst")
;;;ctrl+v粘贴，得下表
(setq dcllst
'(
"MyIdialog:dialog{label=\"离线端头插入块\";"
" :boxed_row{label=\"块名\";"
" :edit_box{key=\"key1\";}"
" :button{key=\"key11\";label=\"&Pick<<\";}"
"}"
" :boxed_column{"
":text{key=\"key12\";value=\"示例：235*2 200*2,20+50\";}"
":edit_box{label=\"距离\";key=\"key2\";value=\"0\";}"
" }"
" :edit_box{label=\"X比例\";key=\"key3\";value=\"1\";}"
" :edit_box{label=\"Y比例\";key=\"key4\";value=\"1\";}"
" :edit_box{label=\"Z比例\";key=\"key5\";value=\"1\";}"
" :boxed_row{label=\"旋转\";"
" :toggle{key=\"key6\";label=\"在屏幕上指定\";value=\"1\";}"
" :edit_box{key=\"key7\";label=\"角度\";value=\"0\";}"
"}"
" :toggle{label=\"镜向\";key=\"key8\";value=\"0\";}"
" ok_cancel;"
"}"
)
)
(xty-sys-makeFbylst (vl-filename-mktemp nil nil ".dcl")dcllst)