[原创]边界轮廓线程序，支持line arc circle *polyline spline ellipse insert
;;边界轮廓线;;最后转成pline线
(vl-load-com)
(defun c:yad_outline(/ viewpt maxmin spl2arc ss_add os cor qa ss n pt1 pt2 l_pt dis ent m)
(defun viewpt(/ a b c d x)
(setq b (getvar "viewsize") c (car (getvar "screensize")) d (cadr (getvar "screensize"))
a (* b (/ c d)) x (setq x (getvar "viewctr")) x (trans x 1 2) c (list (- (car x)(/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)
d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0) c (trans c 2 1) d (trans d 2 1)
)
(list c d)
)
(defun maxmin(lst / x n a b c d)
(setq x (car lst) a (car x) b (cadr x) c (car x) d (cadr x) n 1)
(repeat (max (- (length lst) 1) 0)
(setq x (nth n lst) a (min a (car x)) b (min b (cadr x)) c (max c (car x)) d (max d (cadr x)))
(setq n (1+ n))
)
(list (list a b) (list c d))
)
(defun spl2arc(ent / obj len num spt ept ss i pt1 pt2 pt3 s)
(setq obj (vlax-ename->vla-object ent)
len (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj))
num (1+ (fix (/ len dis)))
num (if (= num 1) 2 num)
spt (vlax-curve-getStartPoint obj)
ept (vlax-curve-getEndPoint obj)
)
(command "_.divide" ent (* 2 num))
(setvar "cecolor" "1")
(setq ss (ssget "_p"))
(if (equal spt ept)
(setq i 1)
(setq i 0)
)
(setq pt3 spt)
(setq s (ssadd))
(repeat num
(setq pt2 (cdr (assoc 10 (entget (ssname ss i)))))
(if (/= num (/ (+ i 2) 2))
(setq pt1 (cdr (assoc 10 (entget (ssname ss (1+ i))))))
(setq pt1 ept)
)
(command "_.arc" pt3 pt2 pt1)
(ssadd (entlast) s)
(setq pt3 pt1)
(setq i (+ 2 i))
)
(command "_.erase" ss ent "")
(setvar "cecolor" "188")
s
)
(defun ss_add(s1 s2 / n)
(setq n -1)
(repeat (sslength s1)
(ssadd (ssname s1 (setq n (1+ n))) s2)
)
s2
)
(prompt "\n请选择要生成边界轮廓线的所有对象（图块轮廓要闭合）：")
(if (setq ss (ssget '((0 . "line,arc,circle,*polyline,spline,ellipse,insert"))))
(progn
(command "_.undo" "_be")
(setq os (getvar "osmode")
cor (getvar "cecolor")
qa (getvar "qaflags")
)
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setq n -1)
(repeat (sslength ss)
(vla-getboundingbox (vlax-ename->vla-object (ssname ss (setq n (1+ n)))) 'pt1 'pt2)
(setq l_pt (append l_pt (list (vlax-safearray->list pt1) (vlax-safearray->list pt2))))
)
(setq l_pt (maxmin l_pt)
pt1 (car l_pt)
pt2 (cadr l_pt)
dis (/ (distance pt1 pt2) 20)
pt1 (polar pt1 (angle pt2 pt1) dis)
pt2 (polar pt2 (angle pt1 pt2) dis)
)
(setq l_pt (maxmin (append (viewpt) (list pt1 pt2))))
(command "_.zoom" "_w" (car l_pt) (cadr l_pt))
(setvar "cecolor" "188")
(command "_.rectang" pt1 pt2)
(setq ent (entlast))
(command "_.boundary" "_a" "_o" "_r" "_i" "_y" "_b" "_n" ent ss "" "" (polar pt1 (angle pt1 pt2) (/ dis 2)) "")
(if (equal (entlast) ent)
(progn
(entdel ent)
(prompt "\n没有边界轮廓线！")
)
(progn
(entdel ent)
(command "_.erase" (ssget "c" pt1 pt1 '((0 . "region") (62 . 188))) "")
(setq m 0)
(if (setq ss (ssget "x" '((0 . "region") (62 . 188))))
(progn
(command "_.union" ss "")
(entmod (subst (cons 62 1) (cons 62 188) (entget (setq ent (entlast)))))
(command "_.explode" ent)
(setq ss (ssget "_p"))
(if (= (cdr (assoc 0 (entget (ssname ss 0)))) "REGION")
(progn
(setvar "qaflags" 1)
(command "_.explode" ss "")
(setq ss (ssget "_p"))
)
)
(if (ssget "p" '((0 . "spline,ellipse")))
(progn
(setq dis (abs (if (setq dis (getreal "\n请输入样条曲线或椭圆的取样距离：<600>")) dis 600.0)))
(if (= dis 0.0) (setq dis 600.0))
)
)
(setq n -1)
(repeat (sslength ss)
(setq ent (ssname ss (setq n (1+ n)))
name (cdr (assoc 0 (entget ent)))
)
(if (or (= name "SPLINE") (= name "ELLIPSE"))
(progn
(ssdel ent ss)
(setq ss (ss_add (spl2arc ent) ss))
(setq n (1- n))
)
)
)
(setq n -1)
(while (setq ent (ssname ss (setq n (1+ n))))
(if (entget ent)
(progn
(command "_.pedit" ent "_y" "_j" ss "" "")
(setq m (1+ m))
)
)
)
)
)
(if (setq ss (ssget "x" '((0 . "*polyline") (62 . 188))))
(progn
(setq n -1)
(repeat (sslength ss)
(entmod (subst (cons 62 1) (cons 62 188) (entget (ssname ss (setq n (1+ n))))))
)
(setq m (+ m (sslength ss)))
)
)
(if (= m 0)
(prompt "\n没有边界轮廓线！")
(prompt (strcat "\n生成" (itoa m) "条边界轮廓线！"))
)
)
)
(setvar "osmode" os)
(setvar "cecolor" cor)
(setvar "qaflags" qa)
(command "_.undo" "_e")
)
)
(princ)
)
(prompt "\n***边界轮廓线yad_outline***YAD建筑")
(princ) 本帖最后由 Bdj 于 2022-6-24 17:25 编辑
这几天在测试这个程序，刚开始的时候在CAD2014里面测试还是没有问题的，但是后来不知怎地，程序出现了问题，然后一直提示：
已提取 2 个环。
已创建 2 个面域。
BOUNDARY 已创建 2 个面域
无效的选项关键字。
; 错误: 函数被取消
输入选项 [闭合(C)/合并(J)/宽度(W)/编辑顶点(E)/拟合(F)/样条曲线(S)/非曲线化(D)/线型生成(L)/反转(R)/放弃(U)]:
将程序放在CAD2015中测试又没有问题，真是起来怪了。
static/image/hrline/1.gif
经过各种测试后发现了出现这种问题的原因是系统变量的问题，通过反查PEDIT命令得知：
如果 PEDITACCEPT 系统变量设定为 1，将不显示该提示，选定对象将自动转换为多段线。
也就是说我的这个系统变量不知何时被设置成了1，导致源代码:
(command "_.pedit" ent "_y" "_j" ss "" "")
这句中的关键字”Y"无效，所以才出现了命令行中“无效的选项关键字。”的提示。
static/image/hrline/1.gif
更改建议是，先将该系统变量用变量记录下来，然后将其设置为0，然后这段程序结束后，在恢复成原来的系统变量:
……
(setq peacpt (getvar "PEDITACCEPT"))
(setvar "PEDITACCEPT" 0)
(command "_.pedit" ent "_y" "_j" ss "" "")
(setvar "PEDITACCEPT" peacpt)
……
如下图：
BDYCAD 发表于 2003-9-20 08:56
我自己很久以前寫了一個,不知適不適合你.試試看.呵呵
(defun c:ee (/ a)
能改一下吗？判断连接后的线是否闭合，在命令行给出提示。谢谢！ 好東東.支持.你有腦總比我的好使.
我想變成SPLINE的.改改看.
----------------------------------
我愛CAD. 我剛剛用了很傻的辦法將這個PLINE變成SPLINE.就是在程序結束后加上
(Command "pedit" "l" "s" "")
可是有尖角的地方變成圓角了.不知高明的做法是如何的.請教樓主一二了.
-----------------------------------------------------
我愛CAD 你转成spline线肯定会这样的，你见过有尖角的spline线吗？ lyy你好,我想請你幫我寫一個自動串接的命令.謝謝!!!
lyy你好,我想請你幫我寫一個自動串接的命令.謝謝!!!
我自己很久以前寫了一個,不知適不適合你.試試看.呵呵
(defun c:ee (/ a)
(setvar "cmdecho" 0)
(setq a (entsel "\nPlease select object the line or arc of pedit:"))
(command "pedit" a "" "J" "all" "" "")
(princ "\nYou are OK")
(setvar "cmdecho" 1)
(princ)
)
;;;不能對付SPLINE \ ELLIPSE
-----------------------------------------------------
我愛CAD, 多多指教. 不知樓主能不能在生成的PLINE可以轉出SPLINE,而且不會變形.就算會變形.在有尖角的地方不要變形得太離普的程序來用用.晚輩的功力現在有限,所以我目前做不到,還請各位高人不吝指教.謝謝啦.
-------------------------------------------------------------
我愛CAD曾經為CAD而瘋狂 好东东.支持.你有脑总比我的好使 <p>很好的东东，但是有时也用不了，</p>