画"云线"增强版本
(defun c:ly (/ yesno r1 r2 tst pt1 pt2 test tmp n new-rr en-data)(setvar "cmdecho" 0)
(initget "R P C E")
(setq yesno (getkword "\n云线轮廓[矩形(R)/多边形(P)/圆形(C)/椭圆形(E)] <R>:"))
(cond
((= yesno "R")
(setq tst 1)
)
((= yesno "r")
(setq tst 1)
)
((= yesno "P")
(setq tst 2)
)
((= yesno "p")
(setq tst 2)
)
((= yesno "C")
(setq tst 3)
)
((= yesno "c")
(setq tst 3)
)
((= yesno "E")
(setq tst 4)
)
((= yesno "e")
(setq tst 4)
)
(t
(setq tst 1)
)
)
(while (= "A" (progn
(initget "A")
(setq pt1 (getpoint "\n[修改弧长(A)/指定起点]<退出>:"))
)
)
(command "_revcloud")
(command)
(initget 6)
(setq r1 (getint "\n指定最小弧长<默认>:")
r2 (getint "\n指定最大弧长<默认>:")
)
(if (= r1 nil)
(setq r1 500)
)
(if (= r2 nil)
(setq r2 800)
)
)
(command "_revcloud" "S" "C" "A" r1 r2)
(command)
(setq n 0
pt2 t
)
(while (and
(= tst 1)
pt2
)
(progn
(if (> n 0)
(setq pt1 (getpoint "\n指定第一个角点<退出>:"))
)
(setq pt2 (getcorner pt1 "\n指定另一个角点："))
(if (= pt2 "")
(setq pt2 nil)
)
(command "_rectang" pt1 pt2)
(command "_revcloud" "O" "" (entlast) "N")
(setq n (+ n 1))
)
)
(while (and
(= tst 2)
pt2
)
(setq test t)
(while test
(progn
(if (> n 0)
(setq pt1 (getpoint "\n指定起始点<退出>: "))
)
(if (setq pt2 (getpoint pt1 "\n指定下一点: "))
(progn
(if (= pt2 "")
(setq pt2 nil)
)
(command "_.pline" "non" pt1 "non" pt2)
(while test
(setq tmp (grread t 7 0))
(redraw)
(cond
((= (car tmp) 3)
(setq pt2 (cadr tmp))
(command "non" pt2)
)
((= (car tmp) 11)
(command "c")
(command "_revcloud" "O" "" (entlast) "N")
(setq test nil)
)
((= (car tmp) 5)
(setq pt (cadr tmp))
(grdraw pt pt1 1 1)
(grdraw pt pt2 2)
)
)
)
)
)
(setq n (+ n 1))
)
)
)
(while (and
(= tst 3)
pt2
)
(progn
(if (> n 0)
(setq pt1 (getpoint "\n指定圆的圆心<退出>:"))
)
(command "_.CIRCLE" pt1 1)
(setq en-data (entget (entlast)))
(setq test t)
(while test
(setq tmp (grread t 7 0))
(redraw)
(cond
((= (car tmp) 3)
(setq pt2 (cadr tmp))
(command "_revcloud" "O" "" (entlast) "N")
(redraw)
(setq test nil)
)
((= (car tmp) 11)
(entdel (entlast))
(setq test nil)
)
((= (car tmp) 5)
(setq pt (cadr tmp))
(grdraw pt pt1 7)
(setq new-rr (distance pt1 pt))
(setq en-data (subst
(cons 40 new-rr)
(assoc 40 en-data)
en-data
)
)
(entmod en-data)
)
)
)
(setq n (+ n 1))
)
)
(while (and
(= tst 4)
pt2
)
(progn
(if (> n 0)
(setq pt1 (getpoint "\n指定椭圆的轴端点<退出>:"))
)
(setq pt2 (getpoint pt1 "\n指定轴的另一个端点:"))
(if (= pt2 "")
(setq pt2 nil)
)
(command "_.ellipse" pt1 pt2 pause)
(command "_revcloud" "O" "" (entlast) "N")
(setq n (+ n 1))
)
)
(setvar "cmdecho" 1)
(princ)
) 感谢作者的分享！ 试了一下，多边形的一用电脑就接近死机，也没见云线画出来，其他OK很方便！ 我04的全提示都有问题。望楼主看下。 本帖最后由 smartstar 于 2012-4-23 12:44 编辑
把 ((= (car tmp) 11) (command "c")
(command "_revcloud" "O" "" (entlast) "N")
(setq test nil)
)
改成 ((= (car tmp) 25) (command "c")
(command "_revcloud" "O" "" (entlast) "N")
(setq test nil)
)
就ok了 很好的程序！不过有两个问题：1、cad2004中出错。2、cad2008中，命令结束时出现“cad2004中”。 ;;;在cad2011下，全部功能可用
(defun c:ly (/ yesno r1 r2 tst pt1 pt2 test tmp n new-rr en-data)
(setvar "cmdecho" 0)
(initget "R P C E")
(setq yesno (getkword "\n云线轮廓[矩形(R)/多边形(P)/圆形(C)/椭圆形(E)] <R>:"))
(cond
((= yesno "R")
(setq tst 1)
)
((= yesno "r")
(setq tst 1)
)
((= yesno "P")
(setq tst 2)
)
((= yesno "p")
(setq tst 2)
)
((= yesno "C")
(setq tst 3)
)
((= yesno "c")
(setq tst 3)
)
((= yesno "E")
(setq tst 4)
)
((= yesno "e")
(setq tst 4)
)
(t
(setq tst 1)
)
)
(while (= "A" (progn
(initget "A")
(setq pt1 (getpoint "\n[修改弧长(A)/指定起点]<退出>:"))
)
)
(command "_revcloud")
(command)
(initget 6)
(setq r1 (getint "\n指定最小弧长<默认>:")
r2 (getint "\n指定最大弧长<默认>:")
)
(if (= r1 nil)
(setq r1 500)
)
(if (= r2 nil)
(setq r2 800)
)
)
(command "_revcloud" "S" "C" "A" r1 r2)
(command)
(setq n 0
pt2 t
)
(while (and
(= tst 1)
pt2
)
(progn
(if (> n 0)
(setq pt1 (getpoint "\n指定第一个角点<退出>:"))
)
(setq pt2 (getcorner pt1 "\n指定另一个角点："))
(if (= pt2 "")
(setq pt2 nil)
)
(command "_rectang" pt1 pt2)
(command "_revcloud" "O" "" (entlast) "N")
(setq n (+ n 1))
)
)
(while (and
(= tst 2)
pt2
)
(setq test t)
(while test
(progn
(if (> n 0)
(setq pt1 (getpoint "\n指定起始点<退出>: "))
)
(if (setq pt2 (getpoint pt1 "\n指定下一点: "))
(progn
(if (= pt2 "")
(setq pt2 nil)
)
(command "_.pline" "non" pt1 "non" pt2)
(while test
(setq tmp (grread t 7 0))
(redraw)
(cond
((= (car tmp) 3)
(setq pt2 (cadr tmp))
(command "non" pt2)
)
((= (car tmp) 25)
(command "c")
(command "_revcloud" "O" "" (entlast) "N")
(setq test nil)
)
((= (car tmp) 5)
(setq pt (cadr tmp))
(grdraw pt pt1 1 1)
(grdraw pt pt2 2)
)
)
)
)
)
(setq n (+ n 1))
)
)
)
(while (and
(= tst 3)
pt2
)
(progn
(if (> n 0)
(setq pt1 (getpoint "\n指定圆的圆心<退出>:"))
)
(command "_.CIRCLE" pt1 1)
(setq en-data (entget (entlast)))
(setq test t)
(while test
(setq tmp (grread t 7 0))
(redraw)
(cond
((= (car tmp) 3)
(setq pt2 (cadr tmp))
(command "_revcloud" "O" "" (entlast) "N")
(redraw)
(setq test nil)
)
((= (car tmp) 11)
(entdel (entlast))
(setq test nil)
)
((= (car tmp) 5)
(setq pt (cadr tmp))
(grdraw pt pt1 7)
(setq new-rr (distance pt1 pt))
(setq en-data (subst
(cons 40 new-rr)
(assoc 40 en-data)
en-data
)
)
(entmod en-data)
)
)
)
(setq n (+ n 1))
)
)
(while (and
(= tst 4)
pt2
)
(progn
(if (> n 0)
(setq pt1 (getpoint "\n指定椭圆的轴端点<退出>:"))
)
(setq pt2 (getpoint pt1 "\n指定轴的另一个端点:"))
(if (= pt2 "")
(setq pt2 nil)
)
(command "_.ellipse" pt1 pt2 pause)
(command "_revcloud" "O" "" (entlast) "N")
(setq n (+ n 1))
)
)
(setvar "cmdecho" 1)
(princ)
)
vlisp2012 发表于 2012-4-23 19:41
;;;在cad2011下，全部功能可用
(defun c:ly (/ yesno r1 r2 tst pt1 pt2 test tmp n new-rr en-data)
(se ...
请测试下2004是否全部可用 。 多边形不能画闭合 2004版能用！ 如何取消手绘样式改为普通样式啊