请教一个编程的问题

bdwzx

我的lisp和DCL程序如下：

(defun c:zlj()
  (setvar "cmdecho" 0)
(setq dd 99)
(setq pt '(0 0 0))
  (setq kp_x 0)
  (setq kp_y 0)
  (setq kp_z 0)
  (while (>= dd 1)
    (dcl_dia13)
    (datanz)
    (def_dia13)
    (prin1)))

(defun dcl_dia13()
  (setq dcl_id (load_dialog "f:/lisp/w.dcl"))
  (new_dialog "dia3" dcl_id)
  (dispos)
 (mapcar 'set_tile tkey_list data_list)
  (set_tile "kax" "0")
  (set_tile "kay" "0")
  (set_tile "kaz" "0")
(action_tile "m1" "(sub_m1)") 
(action_tile "m2" "(sub_m2)")
(action_tile "m3" "(sub_m3)")
(action_tile "m4" "(sub_m4)")
…………
(action_tile "pnt" "(done_dialog 2)")
(action_tile "accept" "(ok_dia13)(done_dialog 3)")
(setq dd(start_dialog))
(cond
  ((= dd 2)(getp)(dcl_dia13))
  ((= dd 3)(inst_dia13)))
  (unload_dialog dcl_id))

(defun sub_m1()
(setq ddtype 1)
  (show_sld "kimage" "f:/slides/1"))
(defun sub_m2()
(setq ddtype 2)
  (show_sld "kimage" "f:/slides/2"))
(defun sub_m3()
(setq ddtype 3)
  (show_sld "kimage" "f:/slides/3"))
(defun sub_m4()
(setq ddtype 4)
  (show_sld "kimage" "f:/slides/4"))
…………
(defun show_sld(key  sld)
  (setq x (dimx_tile key))
(setq y (dimy_tile key))
  (start_image key)
  (fill_image 0 0 x y -2)
  (slide_image 0 -10 x (+ y -10) sld)
  (end_image))

(defun ok_dia13()
(setq agx (angtof(get_tile "kax")))
 (setq agx (* (/ agx pi) 180)))

 (defun getp()
  (setq pt (getpoint "\n指定插入点")))

(defun dispos()
  (setq kp_x(car pt))
  (setq kp_y(cadr pt))
  (setq kp_z(caddr pt))
  (set_tile "key_x"(rtos kp_x 2 2)) 
  (set_tile "key_y"(rtos kp_y 2 2))
  (set_tile "key_z"(rtos kp_z 2 2)))

(defun inst_dia13()
 (cond
((= ddtype 1)(command "insert" "f:/parts/1" pt "" "" "" )
  (command "rotate" (entlast) "" pt agx )(command "zoom" "a" ""))
((= ddtype 2)(command "insert" "f:/parts/2" pt "" "" "" )
  (command "rotate" (entlast) "" pt agx)(command "zoom" "a" ""))
((= ddtype 3)(command "insert" "f:/parts/3" pt "" "" "" )
  (command "rotate" (entlast) "" pt agx )(command "zoom" "a" ""))
((= ddtype 4)(command "insert" "f:/parts/4" pt "" "" "" )
  (command "rotate" (entlast) "" pt agx )(command "zoom" "a" ""))
…………
(defun datanz()
  (setq data_list '() data nil)
  (setq f (open "f:/lisp/partslist.txt" "r"))
  (setq data (read-line f))
  (setq data (read data))
  (while data
     (setq data_list (cons data data_list))
     (setq data (read-line f))
  (setq data (read data)))
  (close f)
  (setq i 1)
   (setq mclist '())
  (setq n(length data_list)) 
(repeat n
   (setq datad (assoc i data_list))
   (setq datad(nth 0 (cdr datad)))
   (setq mc(nth 1 datad))
   (setq mclist (cons mc mclist))
      (setq i (1+ i)))
(setq mclist(reverse mclist))
  (setq data_list(mapcar 'vl-symbol-name mclist)))

(defun def_dia13()
(setq tkey_list '("mc1" "mc2" "mc3" "mc4" ……)))

现在有这样一个问题：我拾取点后希望返回的对话框的图象上有单选按纽选上的图，不希望它什么都没有，怎么处理呀？

xiongdc

求助,谁帮我编一个LISP程序,用来删除同一层上的重复线.谢谢!

ljcgq

好像cad扩展命令上有删除重复线的命令了吧。

xiongdc

(DEFUN C:CF()(SETQ SS(SSGET))
             (if(= ss nil)
             (progn (prompt "\n---*error*选取对象---")
             (setq ss (ssget))))
             (setq s(getint"\n请输入复制方式1)输入层名: (2)选择该层物体: "))
             (if (= S 2 )(progn (while
             (setq LAY (entsel "\n选择该层物体 "))
             (setq LAY (cdr (assoc 8 (entget (car LAY)))))
             (if ( = lay nil)(progn(SETQ LAY(getstring "\n---*error*再一次输入---"))))
             (princ)(COMMAND"COPY" SS "" "0,0"  "0,0" )
             (COMMAND "CHPROP" SS  "" "LA" lay "" "" "")))
             (princ))(if (or(= S 1 ) (= s nil))
             (progn(while(SETQ LAY(GETSTRING"\n层名:_______"))
             (COMMAND"COPY" SS "" "0,0"  "0,0" )
             (COMMAND "CHPROP" SS  "" "LA" lay "" "" ""))))
             (if ( = lay nil)(progn(SETQ LAY(getstring "\n---*error*再一次输入---"))))
             (princ)(command "ucs" "v")
             (command "undo" "end")(PRINC))

xiongdc

(DEFUN C:CF()(SETQ SS(SSGET))
             (if(= ss nil)
             (progn (prompt "\n---*error*选取对象---")
             (setq ss (ssget))))
             (setq s(getint"\n请输入复制方式1)输入层名: (2)选择该层物体: "))
             (if (= S 2 )(progn (while
             (setq LAY (entsel "\n选择该层物体 "))
             (setq LAY (cdr (assoc 8 (entget (car LAY)))))
             (if ( = lay nil)(progn(SETQ LAY(getstring "\n---*error*再一次输入---"))))
             (princ)(COMMAND"COPY" SS "" "0,0"  "0,0" )
             (COMMAND "CHPROP" SS  "" "LA" lay "" "" "")))
             (princ))(if (or(= S 1 ) (= s nil))
             (progn(while(SETQ LAY(GETSTRING"\n层名:_______"))
             (COMMAND"COPY" SS "" "0,0"  "0,0" )
             (COMMAND "CHPROP" SS  "" "LA" lay "" "" ""))))
             (if ( = lay nil)(progn(SETQ LAY(getstring "\n---*error*再一次输入---"))))
             (princ)(command "ucs" "v")
             (command "undo" "end")(PRINC))

xiongdc

层复制有点问题,烦请各位高手帮忙修改并说明原因,谢谢! 我的邮箱:xiongdc@163.com

(DEFUN C:CF()(SETQ SS(SSGET))
             (if(= ss nil)
             (progn (prompt "\n---*error*选取对象---")
             (setq ss (ssget))))
             (setq s(getint"\n请输入复制方式1)输入层名: (2)选择该层物体: "))
             (if (= S 2 )(progn (while
             (setq LAY (entsel "\n选择该层物体 "))
             (setq LAY (cdr (assoc 8 (entget (car LAY)))))
             (if ( = lay nil)(progn(SETQ LAY(getstring "\n---*error*再一次输入---"))))
             (princ)(COMMAND"COPY" SS "" "0,0"  "0,0" )
             (COMMAND "CHPROP" SS  "" "LA" lay "" "" "")))
             (princ))(if (or(= S 1 ) (= s nil))
             (progn(while(SETQ LAY(GETSTRING"\n层名:_______"))
             (COMMAND"COPY" SS "" "0,0"  "0,0" )
             (COMMAND "CHPROP" SS  "" "LA" lay "" "" ""))))
             (if ( = lay nil)(progn(SETQ LAY(getstring "\n---*error*再一次输入---"))))
             (princ)(command "ucs" "v")
             (command "undo" "end")(PRINC))

andyding

你试试看。这个程序好像是隆腾的。

我是搞端子模具的。

(DEFUN C:CF ()
  (SETQ SS (SSGET))
  (if (= ss nil)
    (progn (prompt "\n---*error*选取对象---")
    (setq ss (ssget))
    )
  )
  (setq s (getint "\n请输入复制方式1)输入层名: (2)选择该层物体: "))
  (if (= S 2)
    (progn
      (while
 (setq la (entsel "\n选择该层物体 "))
  (setq la (cdr (assoc 8 (entget (car la)))))
  (if (= la nil)
    (progn (SETQ la (getstring "\n---*error*再一次输入---")))
  )
  (princ)
  (COMMAND "COPY" SS "" "0,0" "0,0")
  (COMMAND "CHPROP" SS "" "LA" la "")
      )
    )
    (princ)
  )
  (if (or (= S 1) (= s nil))
    (progn (while (SETQ LAY (GETSTRING "\n层名:_______"))
      (COMMAND "COPY" SS "" "0,0" "0,0")
      (COMMAND "CHPROP" SS "" "LA" lay "")
    )
    )
  )
  (if (= lay nil)
    (progn (SETQ LAY (getstring "\n---*error*再一次输入---")))
  )
  (princ)
  (command "ucs" "v")
  (command "undo" "end")
  (PRINC)
)