|
|
- 编了一个区域覆盖程序，本来用了李麦克的外围轮廓线程序，但是不支持样条曲线和椭圆，挺苦恼。于是就自己操刀编了一个支持的。实际运行简单图形还行复杂的速度慢，也没其它办法。将就用吧。
- ;;; 外轮廓线，返回轮廓拟合线点列表，支持样条曲线,椭圆,块。
- (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-29 11:21:31