[求助] 请帮忙写一个lisp获得pline线的分段长度

hhh454

请帮忙写一个lisp获得pline线的分段长度，并把每个得到的数据，按顺序变成变量，第一段的长度为a，二段b,等等，最终的目的是想做一个等高矩形的命令，不需要对话框。每个矩形之间有一定的距离

Gu_xl

没有对话框的！

3. (defun c:tt()
4.   (setq osmode (getvar "osmode")
5. cla (getvar "clayer"))
6.   (setvar "osmode" 0)
7.   (setq Height (getreal "\n输入高度：")
8. jj (getreal "\n输入间距："))
9.   (princ "\n选择多段线")
10.   (setq en (entsel))
11.   (setq p0 (cadr en)
12. en (car en)
13. )
14.   (setq la (cdr (assoc 8 (entget en))))
15.   (setvar "clayer" la)
16.   (setq pt (getpoint p0 "\n标注位置："))
17.   (setq endPara (vlax-curve-getEndParam en)
18. n 0)
19.   (repeat (fix endPara)
20.     (setq d (distance (vlax-curve-getPointAtParam en n) (vlax-curve-getPointAtParam en (setq n (1+ n)))))
21.     (command "_.rectang" pt (strcat "@" (rtos d 2) "," (rtos Height 2)))
22.     (setq pt (polar pt 0 (+ d jj)))
23.     )
24.   (setvar "osmode" osmode)
25.   (setvar "clayer" cla)
26.   (princ)
27.   )

(defun c:tt()   (setq osmode (getvar "osmode") cla (getvar "clayer"))   (setvar "osmode" 0)   (setq Height (getreal "\n输入高度：") jj (getreal "\n输入间距："))   (princ "\n选择多段线")   (setq en (entsel))   (setq p0 (cadr en) en (car en) )   (setq la (cdr (assoc 8 (entget en))))   (setvar "clayer" la)   (setq pt (getpoint p0 "\n标注位置："))   (setq endPara (vlax-curve-getEndParam en) n 0)   (repeat (fix endPara)     (setq d (distance (vlax-curve-getPointAtParam en n) (vlax-curve-getPointAtParam en (setq n (1+ n)))))     (command "_.rectang" pt (strcat "@" (rtos d 2) "," (rtos Height 2)))     (setq pt (polar pt 0 (+ d jj)))     )   (setvar "osmode" osmode)   (setvar "clayer" cla)   (princ)   )

Gu_xl

有对话框的！

3. (defun c:tt(/ jj height)
4.   (defun gxl-chkreal (a *key*)
5.         (setq a (read a))
6.         (if (or (= 'INT (type a)) (= 'REAL (type a)))
7.             (progn
8.                (setq chk_flag t)
9.                (setq a a)
10.                );progn
11.             (progn
12.                (alert "\请输入实型数!")
13.                (mode_tile *key* 2)
14.                (setq chk_flag nil)
15.                );progn
16.            );if
17.        )
18. (setq fn (vl-filename-mktemp "aa.dcl"))
19. (setq f (open fn "w"))
20. (write-line "getdata:dialog{" f)
21. (write-line   "label = " 【等高矩形】";" f)
22. (write-line ":boxed_column {" f)
23. (write-line "label = "";" f)
24. (write-line ": edit_box {" f)
25. (write-line "key = "height";" f)
26.   (write-line "value = 500.00;" f)
27. (write-line "label = "高度";" f)
28. (write-line       "width = 20;" f)
29. (write-line            "}" f)
30. (write-line ": edit_box {" f)
31. (write-line "key = "jj";" f)
32.   (write-line "value = 30.00;" f)
33. (write-line "label = "间隔";" f)
34. (write-line       "width = 20;" f)
35. (write-line           " }" f)
36. (write-line "}" f)
37. (write-line     "ok_cancel;" f)
38. (write-line "}" f)
39. (close f)
40.     (setq dlg_code (load_dialog fn))
41.     (new_dialog "getdata" dlg_code)
42.   (setq height 500.0 jj 30.0)
43.   (Action_tile "height" "(setq height (gxl-chkreal $value $key))")
44.       (Action_tile "jj" "(setq jj (gxl-chkreal $value $key))")
45.   (mode_tile "height" 2)
46.     (setq ecode (start_dialog))
47.      (if (= 1 ecode)
48.        (progn
49.   (setq osmode (getvar "osmode")
50. cla (getvar "clayer"))
51.   (setvar "osmode" 0)
52.   (princ "\n选择多段线")
53.   (while (not (and (setq en (entsel)) (= "LWPOLYLINE" (cdr (assoc 0 (entget (car en)))))))
54.     (princ "\n你选择的不是多段线，请重新选择多段线")
55.     )
56.   (setq p0 (cadr en)
57. en (car en)
58. )
59. (setq la (cdr (assoc 8 (entget en))))
60.   (setvar "clayer" la)
61.   (setq pt (getpoint p0 "\n标注位置："))
62.   (setq endPara (vlax-curve-getEndParam en)
63. n 0)
64.   (repeat (fix endPara)
65.     (setq d (distance (vlax-curve-getPointAtParam en n) (vlax-curve-getPointAtParam en (setq n (1+ n)))))
66.     (if (> d 0)
67.       (progn
68.     (command "_.rectang" pt (strcat "@" (rtos d 2) "," (rtos Height 2)))
69.     (setq pt (polar pt 0 (+ d jj)))
70.     )
71.       )
72.     )
73.   (setvar "osmode" osmode)
74.   (setvar "clayer" cla)
75.   (princ)
76.   )
77.        )
78.     (vl-file-delete  fn)
79. (princ)
80. )

(defun c:tt(/ jj height)   (defun gxl-chkreal (a *key*)         (setq a (read a))         (if (or (= 'INT (type a)) (= 'REAL (type a)))             (progn                (setq chk_flag t)                (setq a a)                );progn             (progn                (alert "\请输入实型数!")                (mode_tile *key* 2)                (setq chk_flag nil)                );progn            );if        ) (setq fn (vl-filename-mktemp "aa.dcl")) (setq f (open fn "w")) (write-line "getdata:dialog{" f) (write-line   "label = " 【等高矩形】";" f) (write-line ":boxed_column {" f) (write-line "label = "";" f) (write-line ": edit_box {" f) (write-line "key = "height";" f)   (write-line "value = 500.00;" f) (write-line "label = "高度";" f) (write-line       "width = 20;" f) (write-line            "}" f) (write-line ": edit_box {" f) (write-line "key = "jj";" f)   (write-line "value = 30.00;" f) (write-line "label = "间隔";" f) (write-line       "width = 20;" f) (write-line           " }" f) (write-line "}" f) (write-line     "ok_cancel;" f) (write-line "}" f) (close f)     (setq dlg_code (load_dialog fn))     (new_dialog "getdata" dlg_code)   (setq height 500.0 jj 30.0)   (Action_tile "height" "(setq height (gxl-chkreal $value $key))")       (Action_tile "jj" "(setq jj (gxl-chkreal $value $key))")   (mode_tile "height" 2)     (setq ecode (start_dialog))      (if (= 1 ecode)        (progn   (setq osmode (getvar "osmode") cla (getvar "clayer"))   (setvar "osmode" 0)   (princ "\n选择多段线")   (while (not (and (setq en (entsel)) (= "LWPOLYLINE" (cdr (assoc 0 (entget (car en)))))))     (princ "\n你选择的不是多段线，请重新选择多段线")     )   (setq p0 (cadr en) en (car en) ) (setq la (cdr (assoc 8 (entget en))))   (setvar "clayer" la)   (setq pt (getpoint p0 "\n标注位置："))   (setq endPara (vlax-curve-getEndParam en) n 0)   (repeat (fix endPara)     (setq d (distance (vlax-curve-getPointAtParam en n) (vlax-curve-getPointAtParam en (setq n (1+ n)))))     (if (> d 0)       (progn     (command "_.rectang" pt (strcat "@" (rtos d 2) "," (rtos Height 2)))     (setq pt (polar pt 0 (+ d jj)))     )       )     )   (setvar "osmode" osmode)   (setvar "clayer" cla)   (princ)   )        )     (vl-file-delete  fn) (princ) )

hhh454

谢谢，万分感谢，

669423907

非常好的程序！谢谢版主！

cooolseee

谢谢楼主的启发，我有想法了

caoxu123

很受启发 学习了！！！！

meja

Gu_xl 发表于 2010-11-9 19:50
有对话框的！

这个无法运行，很奇怪啊