我编写DCL的方法

自贡黄明儒

学习了 baitang36 一键合并DCL和LSP文件，我谈谈自己编写DCL的方法，供大家参考。
《操作对话框》
第一步，用vlide编写DCL
第二步，用命令dcl2lsp转成lisp文件
第三步，写(getdata) (setdata)(do3) 和主函数(do1)
大功告成！

下面是我用的dcl2lsp

1. ;;===========2014.12.24==================DCL文件转成需要的.lsp
   
2. (defun c:dcl2lsp (/ DCLNAME FN1 FN1L FN2 FN2L FNAME1 FNAME2 INITDIR K)
   
3.   (setq fname1 (getfiled "***选择DCL文件***" "" "dcl" 16))
   
4.   (setq Initdir (strcat (vl-filename-directory fname1) "\\22"))
   
5.   (setq fn1 (open fname1 "r"))
   
6.   (setq fname2 (getfiled "***Lisp文件保存到***" Initdir "lsp" 1))
   
7.   (setq fn2 (open fname2 "w"))
   
8.   (write-line "(defun dialog ()" fn2)
   
9.   (write-line "(setq fname (vl-filename-mktemp nil nil \".dcl\"))"
   
10.         fn2
    
11.   )
    
12.   (write-line "(setq fn (open fname \"w\"))" fn2)
    
13.   (while (setq fn1l (read-line fn1))
    
14.     (if  (wcmatch fn1l "*:*dialog*")
    
15.       (setq DCLName (VL-STRING-TRIM " " (car (parse3 fn1l "[^:]+"))))
    
16.     )   
    
17.     (setq fn2l (strcat "(write-line " (VL-PRIN1-TO-STRING fn1l) " fn)"))
    
18.     (write-line fn2l fn2)
    
19.   )
    
20.   (close fn1)
    
21.   
    
22.   (write-line "(close fn)" fn2)
    
23.   (write-line "" fn2)   
    
24.   (write-line "(setq dclid (load_dialog fname))" fn2)
    
25.   (write-line ";;如果不循环，去掉下面123" fn2)
    
26.   (write-line "(setq return# 3);1" fn2)
    
27.   (write-line "(while (> return# 2);2" fn2)
    
28.   (write-line (strcat "(new_dialog \"" DCLName "\" dclid)") fn2)
    
29.   (write-line "(setdata)" fn2)
    
30.   (write-line "(action_tile \"accept\" \"(getdata)(done_dialog 1)\")"
    
31.         fn2
    
32.   )  
    
33.   (write-line "(setq return# (start_dialog))" fn2)
    
34.   (write-line "(cond ((equal return# 3) (do3)));3" fn2)
    
35.   (write-line ")" fn2)
    
36.   (write-line "(unload_dialog dclid)" fn2)  
    
37.   (write-line "(vl-file-delete fname)" fn2)
    
38.   (write-line "(cond ((equal return# 1) (do1)))" fn2)
    
39.   (write-line ")" fn2)  
    
40.   (close fn2)
    
41.   (princ"\n dcl2lsp")
    
42.   (princ)
    
43. )
    
44. ;;===========2014.12.24==================DCL文件转成需要的.lsp

;;===========2014.12.24==================DCL文件转成需要的.lsp<br /> (defun c:dcl2lsp (/ DCLNAME FN1 FN1L FN2 FN2L FNAME1 FNAME2 INITDIR K)<br />   (setq fname1 (getfiled "***选择DCL文件***" "" "dcl" 16))<br />   (setq Initdir (strcat (vl-filename-directory fname1) "\\22"))<br />   (setq fn1 (open fname1 "r"))<br />   (setq fname2 (getfiled "***Lisp文件保存到***" Initdir "lsp" 1))<br />   (setq fn2 (open fname2 "w"))<br />   (write-line "(defun dialog ()" fn2)<br />   (write-line "(setq fname (vl-filename-mktemp nil nil \".dcl\"))"<br />         fn2<br />   )<br />   (write-line "(setq fn (open fname \"w\"))" fn2)<br />   (while (setq fn1l (read-line fn1))<br />     (if  (wcmatch fn1l "*:*dialog*")<br />       (setq DCLName (VL-STRING-TRIM " " (car (parse3 fn1l "[^:]+"))))<br />     )    <br />     (setq fn2l (strcat "(write-line " (VL-PRIN1-TO-STRING fn1l) " fn)"))<br />     (write-line fn2l fn2)<br />   )<br />   (close fn1)<br />   <br />   (write-line "(close fn)" fn2)<br />   (write-line "" fn2)   <br />   (write-line "(setq dclid (load_dialog fname))" fn2)<br />   (write-line ";;如果不循环，去掉下面123" fn2) <br />   (write-line "(setq return# 3);1" fn2)<br />   (write-line "(while (> return# 2);2" fn2)<br />   (write-line (strcat "(new_dialog \"" DCLName "\" dclid)") fn2)<br />   (write-line "(setdata)" fn2)<br />   (write-line "(action_tile \"accept\" \"(getdata)(done_dialog 1)\")"<br />         fn2<br />   )  <br />   (write-line "(setq return# (start_dialog))" fn2)<br />   (write-line "(cond ((equal return# 3) (do3)));3" fn2)<br />   (write-line ")" fn2)<br />   (write-line "(unload_dialog dclid)" fn2)  <br />   (write-line "(vl-file-delete fname)" fn2)<br />   (write-line "(cond ((equal return# 1) (do1)))" fn2)<br />   (write-line ")" fn2)  <br />   (close fn2)<br />   (princ"\n dcl2lsp")<br />   (princ)<br /> )<br /> ;;===========2014.12.24==================DCL文件转成需要的.lsp

e2002

接着黄大师的话题，我也说说我是怎么写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中都是固定代码和套路。

yaojing38

补个函数，防小白迷路
(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"，连续编号。。。。

masterlong

我就喜欢手写DCL
最主要的原因
我需要精细调整控件的位置
属于特殊强迫症
没办法
这用DCG做起来也没方便多少

飞诗体验过没深入使用
感觉还没有DCG方便

最后
非常不喜欢dcl2lsp的方式
主要还是隔上一段时间
就忍不住要动动自己那些程序
加几个或固定或临时的功能

自贡黄明儒

对于 (getdata) (setdata)如何写呢？
我觉得采用highflybird大师的办法，先将edit_box toggle list_box....的key连续编号，以便于保存和获取
如

1. (defun getdata (/ DCLDATA I KEY)
   
2.     (setq i 0)
   
3.     (repeat 5                                                    ;"key1"到"key5"
   
4.       (setq i (1+ i))
   
5.       (setq key (strcat "Key" (itoa i)))
   
6.       (set (read key) (get_tile key))
   
7.       (setq DCLData (cons (cons key (eval (read key))) DCLData))
   
8.     )
   
9.     (Setenv "MyD" (VL-PRIN1-TO-STRING DCLData))
   
10.   )
    
11.   (defun setdata (/ DCLDATA X)
    
12.     (cond ((setq DCLData (getenv "MyD"))
    
13.            (setq DCLData (read DCLData))
    
14.            (mapcar '(lambda (x) (Set_tile (car x) (cdr x))) DCLData)
    
15.           )
    
16.     )
    
17.   )

(defun getdata (/ DCLDATA I KEY)<br />     (setq i 0)<br />     (repeat 5                                                    ;"key1"到"key5"<br />       (setq i (1+ i))<br />       (setq key (strcat "Key" (itoa i)))<br />       (set (read key) (get_tile key))<br />       (setq DCLData (cons (cons key (eval (read key))) DCLData))<br />     )<br />     (Setenv "MyD" (VL-PRIN1-TO-STRING DCLData))<br />   )<br />   (defun setdata (/ DCLDATA X)<br />     (cond ((setq DCLData (getenv "MyD"))<br />            (setq DCLData (read DCLData))<br />            (mapcar '(lambda (x) (Set_tile (car x) (cdr x))) DCLData)<br />           )<br />     )<br />   )

magicheno

感谢大佬分享~方便举个完整的例子不

hhh454

我觉得已经非常完美了，很有价值的代码，希望楼主补全一个例子，学习了

中国梦

谢谢楼主分享

gdfyhao

学习到了新方法，谢谢，再举个例子吧

x_s_s_1

贴个自己常用的，没有老黄的直接，仅针对DCL，没考虑控制。

1. ;;;=============================================
   
2. ;;;      通用函数  文本转为LIST复制到剪贴板
   
3. ;;;参数： file------文件
   
4. ;;;       name------表名
   
5. ;;;返回值：nil
   
6. (defun xty-sys-copyclipdcl (file name / rf str html t1)
   
7.   (setq rf (open file "r"))
   
8.   (setq str (strcat "(setq " name "'(\n"))
   
9.   (while (setq t1 (read-line rf))
   
10.     (setq
    
11.       str (strcat str "\"" (xty-str-substall "\\\"" "\"" t1) "\"\n")
    
12.     )
    
13.   )
    
14.   (setq str (strcat str ")\n)"))
    
15.   (setq HTML (vlax-create-object "htmlfile"))
    
16.   (vlax-invoke
    
17.     (vlax-get (vlax-get HTML 'PARENTWINDOW) 'CLIPBOARDDATA)
    
18.     'SETDATA
    
19.     "Text"
    
20.     str
    
21.   )
    
22.   (vlax-release-object HTML)
    
23.   (close rf)
    
24. )
    
25. ;;;=============================================
    
26. ;;;      通用函数  写字符串表到文件
    
27. ;;;参数：filename----文件名
    
28. ;;;      strlst------需写入文件字符串表
    
29. ;;;返回值：文件名
    
30. (defun xty-sys-makeFbylst (filename strlst / f n)
    
31.   (setq f (open filename "w"))
    
32.   (foreach n strlst
    
33.     (if  (eq (type n) 'STR)
    
34.       (write-line n f)
    
35.       (write-line (vl-princ-to-string n) f)
    
36.       )
    
37.     )
    
38.   (close f)
    
39.   filename
    
40.   )

;;;=============================================<br /> ;;;      通用函数  文本转为LIST复制到剪贴板<br /> ;;;参数： file------文件<br /> ;;;       name------表名<br /> ;;;返回值：nil<br /> (defun xty-sys-copyclipdcl (file name / rf str html t1)<br />   (setq rf (open file "r"))<br />   (setq str (strcat "(setq " name "'(\n"))<br />   (while (setq t1 (read-line rf))<br />     (setq<br />       str (strcat str "\"" (xty-str-substall "\\\"" "\"" t1) "\"\n")<br />     )<br />   )<br />   (setq str (strcat str ")\n)"))<br />   (setq HTML (vlax-create-object "htmlfile"))<br />   (vlax-invoke<br />     (vlax-get (vlax-get HTML 'PARENTWINDOW) 'CLIPBOARDDATA)<br />     'SETDATA<br />     "Text"<br />     str<br />   )<br />   (vlax-release-object HTML)<br />   (close rf)<br /> )<br /> ;;;=============================================<br /> ;;;      通用函数  写字符串表到文件<br /> ;;;参数：filename----文件名<br /> ;;;      strlst------需写入文件字符串表<br /> ;;;返回值：文件名<br /> (defun xty-sys-makeFbylst (filename strlst / f n)<br />   (setq f (open filename "w"))<br />   (foreach n strlst<br />     (if  (eq (type n) 'STR)<br />       (write-line n f)<br />       (write-line (vl-princ-to-string n) f)<br />       )<br />     )<br />   (close f)<br />   filename<br />   )

1. (xty-sys-copyclipdcl (getfiled "dcl" "" "dcl" 16) "dcllst")
   
2. ;;;ctrl+v粘贴，得下表
   
3. (setq dcllst
   
4.        '(
   
5.    "MyIdialog:dialog{label=\"离线端头插入块\";"
   
6.    " :boxed_row{label=\"块名\";"
   
7.    "    :edit_box{key=\"key1\";}"
   
8.    "    :button{key=\"key11\";label=\"&Pick<<\";}"
   
9.    "  }"
   
10.    " :boxed_column{"
    
11.    "  :text{key=\"key12\";value=\"示例：235*2 200*2,20+50\";}"
    
12.    "  :edit_box{label=\"距离\";key=\"key2\";value=\"0\";}"
    
13.    " }"
    
14.    " :edit_box{label=\"X比例\";key=\"key3\";value=\"1\";}"
    
15.    " :edit_box{label=\"Y比例\";key=\"key4\";value=\"1\";}"
    
16.    " :edit_box{label=\"Z比例\";key=\"key5\";value=\"1\";}"
    
17.    " :boxed_row{label=\"旋转\";"
    
18.    "    :toggle{key=\"key6\";label=\"在屏幕上指定\";value=\"1\";}"
    
19.    "    :edit_box{key=\"key7\";label=\"角度\";value=\"0\";}"
    
20.    "  }"
    
21.    " :toggle{label=\"镜向\";key=\"key8\";value=\"0\";}"
    
22.    " ok_cancel;"
    
23.    "}"
    
24.    )
    
25.       )
    
26. (xty-sys-makeFbylst (vl-filename-mktemp nil nil ".dcl")dcllst)

(xty-sys-copyclipdcl (getfiled "dcl" "" "dcl" 16) "dcllst")<br /> ;;;ctrl+v粘贴，得下表<br /> (setq dcllst<br />        '(<br />    "MyIdialog:dialog{label=\"离线端头插入块\";"<br />    " :boxed_row{label=\"块名\";"<br />    "    :edit_box{key=\"key1\";}"<br />    "    :button{key=\"key11\";label=\"&Pick<<\";}"<br />    "  }"<br />    " :boxed_column{"<br />    "  :text{key=\"key12\";value=\"示例：235*2 200*2,20+50\";}"<br />    "  :edit_box{label=\"距离\";key=\"key2\";value=\"0\";}"<br />    " }"<br />    " :edit_box{label=\"X比例\";key=\"key3\";value=\"1\";}"<br />    " :edit_box{label=\"Y比例\";key=\"key4\";value=\"1\";}"<br />    " :edit_box{label=\"Z比例\";key=\"key5\";value=\"1\";}"<br />    " :boxed_row{label=\"旋转\";"<br />    "    :toggle{key=\"key6\";label=\"在屏幕上指定\";value=\"1\";}"<br />    "    :edit_box{key=\"key7\";label=\"角度\";value=\"0\";}"<br />    "  }"<br />    " :toggle{label=\"镜向\";key=\"key8\";value=\"0\";}"<br />    " ok_cancel;"<br />    "}"<br />    )<br />       )<br /> (xty-sys-makeFbylst (vl-filename-mktemp nil nil ".dcl")dcllst)