外围轮廓线（支持块样条曲线椭圆）
编了一个区域覆盖程序，本来用了李麦克的外围轮廓线程序，但是不支持样条曲线和椭圆，挺苦恼。于是就自己操刀编了一个支持的。实际运行简单图形还行复杂的速度慢，也没其它办法。将就用吧。;;; 外轮廓线，返回轮廓拟合线点列表，支持样条曲线,椭圆,块。
(defun outline (ss / alst ar b e1 e2 en en1 en2 en3 ent f i ii j lst lst1 lstx lsty maxpoint minpoint name name1 obj pmax pmin pt
snap ss2 ss3 ss4 vc vh vs x zw
)
(defun ssnext (en / ss)
(setq ss (ssadd))
(while (setq en (entnext en))
(if (not (member (cdr (assoc 0 (entget en))) (list "ATTRIB" "VERTEX" "SEQEND")))
(setq ss (ssadd en ss))
)
)
ss
)
(vl-load-com)
(setq snap (getvar "osmode"))
(setvar "osmode" 0)
(setq lstx '()
lsty '()
)
(setq en1 (entlast))
(repeat (setq i (sslength ss)) ; 计算ss最大外围框
(setq name (ssname ss (setq i (1- i))))
(vla-getboundingbox (vlax-ename->vla-object name) 'minpoint 'maxpoint)
(setq pmax (vlax-safearray->list maxpoint)
pmin (vlax-safearray->list minpoint)
lstx (cons (car pmin) (cons (car pmax) lstx))
lsty (cons (cadr pmin) (cons (cadr pmax) lsty))
)
)
(setq lstx (vl-sort lstx '<)
lsty (vl-sort lsty '<)
)
(setq b (* 0.1 (max
(- (last lstx) (car lstx))
(- (last lsty) (car lsty))
)
)
)
(setq lst (list (list (- (car lstx) b) (- (car lsty) b)) (list (+ (last lstx) b) (- (car lsty) b)) (list (+ (last lstx) b)
(+ (last lsty) b)
) (list (- (car lstx) b)
(+ (last lsty) b)
)
)
)
(entmake (append
(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 1))
(mapcar
'(lambda (pt)
(cons 10 pt)
)
lst
)
)
) ; 生成大一点的外围框
(setq vc (trans (getvar "viewctr") 1 2) ; 计算当前窗口坐标用于放大窗口
vh (getvar "viewsize")
vs (mapcar
'/
(list (* (apply
'/
(getvar "screensize")
) vh
) vh
)
'(2 2)
)
)
(setq zw (mapcar
'(lambda (f)
(trans (mapcar
f
vc
vs
) 2 1
)
)
'(- +)
)
)
(vl-cmdf "ZOOM" "W" (list (- (car lstx) b) (- (car lsty) b)) (list (+ (last lstx) b) (+ (last lsty) b))) ; 放大窗口
(setq ss (ssadd (entlast) ss))
(setq pt (list (- (car lstx) (* 0.5 b)) (- (car lsty) (* 0.5 b))))
(setq en2 (entlast))
(vl-cmdf "boundary" "A" "O" "R" "B" "N" ss "" "" pt "") ; 生成面域
(vl-cmdf "ZOOM" "W" (car zw) (cadr zw)) ; 恢复原窗口
(setq alst '())
(if (setq ss2 (ssnext en2))
(progn
(repeat (setq i (sslength ss2))
(setq name (ssname ss2 (setq i (1- i))))
(if (= (cdr (assoc 0 (entget name))) "REGION")
(setq obj (vlax-ename->vla-object name)
ar (vla-get-area obj)
alst (cons (list ar name) alst)
)
)
)
(setq alst (vl-sort alst (function (lambda (e1 e2)
(> (car e1) (car e2))
)
)
)
)
(setq alst (cdr alst))
(setq ss4 (ssadd))
(if (car alst)
(progn
(setq name (cadr (car alst))) ; 取第二大面积，第一大为外围框不选用
(setq en3 (entlast))
(vl-cmdf "explode" name) ; 炸开面域
(if (setq ss3 (ssnext en3))
(repeat (setq j (sslength ss3))
(setq name1 (ssname ss3 (setq j (1- j))))
(setq obj (vlax-ename->vla-object name1))
(setq ent (entget name1))
(if (member (cdr (assoc 0 ent)) (list "SPLINE" "CIRCLE" "ARC" "ELLIPSE")) ; 如果线是样条椭圆圆圆弧生成拟合线
(progn
(setq lst (list (vlax-curve-getstartpoint obj)))
(setq b (* 0.02 (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))))
(setq ii 1)
(repeat 49
(setq lst (cons (vlax-curve-getpointatdist obj (* ii b)) lst))
(setq ii (1+ ii))
)
(setq lst (cons (vlax-curve-getendpoint obj) lst))
(entmake (append
(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)))
(mapcar
'(lambda (pt)
(cons 10 pt)
)
lst
)
)
)
(setq ss4 (ssadd (entlast) ss4))
)
(setq ss4 (ssadd name1 ss4))
)
)
)
(setvar "peditaccept" 1)
(vl-cmdf "PEDIT" "M" ss4 "" "J" 0.1 "") ; 将外围线连接成一条多段线，并取端点
(setq lst1 (mapcar
'cdr
(vl-remove-if-not '(lambda (x)
(= (car x) 10)
) (entget (entlast))
)
)
)
)
)
(vl-cmdf "erase" (ssnext en1) "") ; 删除过程中产生的所有图元
)
)
(setvar "osmode" snap)
lst1
)
;;; 测试1：生成外围轮廓线
(defun c:aa (/ lst pt ss)
(if (setq ss (ssget '((0 . "*LINE,CIRCLE,ARC,ELLIPSE,INSERT"))))
(progn
(setq lst (outline ss))
(entmake (append
(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 1)
(cons 62 1)
)
(mapcar
'(lambda (pt)
(cons 10 pt)
)
lst
)
)
)
)
)
(princ)
)
;;; 测试2：区域覆盖
(defun c:bb (/ #err $orr cp h i lenid ll lst n pt pts s1 snap ss ur w wh)
(defun gxl-makewipeout (pts / cp h lenid ll lst pt ur w wh) ; 点表转区域覆盖
(setq lenid (strlen (vl-princ-to-string (vlax-get-acad-object))))
(cond
((= lenid 39) ; =>39就是32位autocad
(if (not (member "acwipeout.arx" (arx)))
(arxload "acwipeout.arx")
)
)
((eq 47 lenid) ; =>47就是47位autocad
(if (not (member "acismui.arx" (arx)))
(arxload "acismui.arx")
)
)
)
(if (not (equal (car pts) (last pts) 1e-6))
(setq pts (cons (last pts) pts))
)
(setq ll (apply
'mapcar
(cons 'min pts)
)
ur (apply
'mapcar
(cons 'max pts)
)
wh (mapcar
'-
ur
ll
)
w (car wh)
h (cadr wh)
cp (mapcar
'*
(mapcar
'+
ll
ur
)
'(0.5 0.5 0.5)
)
)
(foreach pt pts
(setq lst (cons (list 14 (/ (car (setq pt (mapcar
'-
pt
cp
)
)
) w
) (- (/ (cadr pt) h))
) lst
)
)
)
(setq lst (reverse lst))
(entmakex (append
(list '(0 . "WIPEOUT") '(100 . "AcDbEntity") '(100 . "AcDbWipeout") (cons 10 ll) (list 11 w 0.0) (list 12 0.0 h) '
(280 . 1) '(71 . 2)
)
lst
)
)
)
(defun #err (s / i n s1) ; 出错处理子函数
(setvar "osmode" snap)
((if command-s
command-s
vl-cmdf
) ".undo"
"e"
)
(setq *error* $orr)
)
(vl-load-com)
(vl-cmdf ".UNDO" "BE") ; 设置undo起点
(setvar "cmdecho" 0)
(setq snap (getvar "osmode"))
(setvar "osmode" 0)
(setq $orr *error*)
(setq *error* #err)
(if (setq ss (ssget '((0 . "*LINE,CIRCLE,ARC,ELLIPSE,INSERT"))))
(progn
(setq lst (outline ss))
(gxl-makewipeout lst)
(setq name (entlast))
(vl-cmdf "draworder" name "" "B")
(vl-cmdf "draworder" ss name "" "F")
)
)
(setvar "osmode" snap)
(setq *error* $orr)
(vl-cmdf ".UNDO" "E") ; 设置undo终点
(princ)
)
小鸟 发表于 2024-7-28 16:00
刚才试了下怎么圆弧都变成直线了
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=173674&highlight=%C2%D6%C0%AA%CF%DF 有spline时影响精度，最好用面域处理 刚才试了下怎么圆弧都变成直线了 谢谢分享 刚试了下,圆弧是变成小段小段直线组成，精度有点影响，但问题不大，基本满足一般图形处理了，感谢楼主分享。。。 圆弧是变成小段小段直线的原因是做区域覆盖用的。如果目的不是区域覆盖，稍微改一下就行了 感谢大师的作品，非常好用 大佬出手必属精品，感谢分享 支持狼大师..........