【Gu_xl】[讨论]根据选择的直线·、圆弧等实体，自动生成有实体围成的所有边界

Gu_xl 发表于 2010-2-4 22:51:00

本帖最后由 Gu_xl 于 2013-5-14 09:59 编辑

;;;La为图层名
(defun Layer_zdsb (La / sel make_point_list n mn en entype pt1 pt2 pL sel k p1 p2 enlast ensel)
;;;===============================
;;;表操作函数
;;;判断点 p1 是否在点集PL中，是返回T ，不是返回nil，a为精度
;;;例 (IsInPointList '(1.0001 1.001 0) '((1 1 0) (2 1 0)) 0.001),返回T
(defun IsInPointList (p1 PL a)
;(setq n (length PL))
(if (member t (mapcar '(lambda (b) (equal p1 b a)) PL))
t
nil
)
)
;;;取出图元索引i对应的值
(defun dxf (ent i)
(cdr (assoc i (entget ent)))
)
;;;取圆弧的起点、终点。中点
(defun arc_3point (a / cenp radius STP ENPmp arcmidpoint)
(setq cenp (cdr (assoc 10 (entget a))))
(setq radius (cdr (assoc 40 (entget a))))
(setq STP (vlax-curve-getPointAtParam A (vlax-curve-getstartparam A)))
(setq ENP (vlax-curve-getPointAtParam A (vlax-curve-getEndParam A)))
(setq arcmidpoint (polar (polar stp (angle stp enp) (/ (distance STP ENP) 2.0))
(angle cenp (polar stp (angle stp enp) (/ (distance STP ENP) 2.0)))
(- radius (distance (polar stp (angle stp enp) (/ (distance STP ENP) 2.0)) cenp))))
(list stp enp arcmidpoint)
)

;;;根据选择集中的line、arc、circle，生成点集
(defun make_point_list (s / PL)
(setq n 0 PL '() mn (sslength s))
(repeat mn
(setq en (ssname s n)
enType (dxf en 0))
(cond
((= enType "LINE")
(setq pt1 (dxf en 10)
pt2 (dxf en 11))
(if (not (IsInPointList pt1 pl 0.00001))
(setq pl (cons pt1 pl))
);if
(if (not (IsInPointList pt2 pl 0.00001))
(setq pl (cons pt2 pl))
);if
)
((= enType "ARC")
(setq pt1 (car (arc_3point en))
pt2 (cadr (arc_3point en))
)
(if (not (IsInPointList pt1 pl 0.00001))
(setq pl (cons pt1 pl))
);if
(if (not (IsInPointList pt2 pl 0.00001))
(setq pl (cons pt2 pl))
);if

)

);cond
(setq n (1+ n))
);repeat
(setq pl pl)
);make_point_list
;;;此处SEL选择集可自行修改为命令行选择代码
(setq sel (ssget "x" (list '(0 . "line,arc,circle") (cons 8 La))))
(if sel
(progn
(setq Plist (make_point_list sel))
(setq enlast (entlast) ensel (ssadd))
(setvar "CLAYER" la)
(command "_.boundary" "a" "b" "n" sel "" "" )
(setq n -1
mn 0
k (length Plist))
(repeat k
(setq p0 (nth (setq n (1+ n)) Plist) mn n)
(repeat (- k n 1)
(setq p1 (nth (setq mn (1+ mn)) Plist))
(setq p2 (midpoint p0 p1))
(command p2)
);repeat
);repeat
(command "")
(while (setq en (entnext enlast))
(setq enlast en)
(ssadd en ensel)
);while
(command "erase" sel "")
(setq ensel ensel)
);progn
nil
);if
)
程序缺点是选择的实体多了，计算速度太慢，请高手讨论，提供共好的算法！
程序加以改进后，完整代码如下：

;;;选择直线园弧园自动生成边界,程序作者：Gu_xl时间：2010年2月
(defun c:BianJie (/ NewSel sel n mn en entype pt1 pt2 pL sel k p1 p2 enlast ensel)
;;;选择集合并，返回合并后选择集，参数选择集图元都可以
(defun SS_SSjoin (ss1 ss2 / ename ss cnt)

(ifss1
 (progn
(if (= (type ss1) 'ENAME)
(progn
 (setq
 ename ss1
 ss1 (ssadd)
 )
 (ssadd ename ss1)
)
)
 )
)

(ifss2
 (progn
(if (= (type ss2) 'ENAME)
(progn
 (setq
 ename ss2
 ss2 (ssadd)
 )
 (ssadd ename ss2)
)
)
 )
)

(setq ss (ssadd))

(if(and ss1 ss2)
 (progn
(setq ssss2
 cnt 0
)
(repeat(sslength ss1)
(ssadd (ssname ss1 cnt) ss)
(setq cnt (1+ cnt))
)
 )
)

(if(and ss1 (not ss2))
 (setq ss ss1)
)

(if(and ss2 (not ss1))
 (setq ss ss2)
)

(if(> (sslength ss) 0)
 (eval ss)
 nil
)
)
;;;========================================================================================
;;选择集求交点子程序
;;;========================================================================================
(defun interss
(ss / i ssl aobj1 aobj2 n2 ipts pts pts1 pt el objL objL1)
(setq ssl(sslength ss)
i -1
objL '()
)
;;;OBJL 对象表 '((obj1) (obj2)...)
(repeat ssl
 (setq
objL
(cons (list (vlax-ename->vla-object (ssname ss (setq i (1+ i)))))
 objL
)
 )
) ;repeat
(setq i -1)
(repeat ssl
 (setq obj1 (nth (setq i (1+ i)) objL))
 (setq objL1 (cdr (member obj1 objL))
 aobj1 (car obj1)
 )
 (setq mm(- ssl i 1)
 m-1
 pts'()
 )
 (repeat mm
(setq obj2 (nth (setq m (1+ m)) objL1))
(setq aobj2 (car obj2)
 pts1'()
)
(setq ipts (vla-intersectwith
 aobj1
 aobj2
 0
 )
 ipts (vlax-variant-value ipts)
)
(if (> (vlax-safearray-get-u-bound ipts 1) 0) ;是否有交点
(progn
 (setq ipts
 (vlax-safearray->list ipts)
 )
 (while (> (length ipts) 0)
 (setq pt (list (car ipts)
 (cadr ipts)
 (caddr ipts)
 )
 )
 (cond
((or (= (vla-get-objectname aobj2) "AcDbLine")
 (= (vla-get-objectname aobj2) "AcDbArc")
)
(if (not (or (equal (vlax-curve-getstartpoint aobj2)
 pt
 0.0001
 )
 (equal (vlax-curve-getendpoint aobj2)
 pt
 0.0001
 )
 )
 )
 (setq pts1 (cons pt pts1))
 ;(setq objL (subst (append obj2 (list pt)) obj2 objL))
) ;if
)
((= (vla-get-objectname aobj2) "AcDbCircle")
 ;(setq objL (subst (append obj2 (list pt)) obj2 objL))
(setq pts1 (cons pt pts1))
)
 ) ;cond
 (cond
((or (= (vla-get-objectname aobj1) "AcDbLine")
 (= (vla-get-objectname aobj1) "AcDbArc")
)
(if (not (or (equal (vlax-curve-getstartpoint aobj1)
 pt
 0.0001
 )
 (equal (vlax-curve-getendpoint aobj1)
 pt
 0.0001
 )
 )
 )
 (setq pts (cons pt pts))
) ;if
)
((= (vla-get-objectname aobj1) "AcDbCircle")
(setq pts (cons pt pts))
)
 ) ;cond
 (setq ipts (cdddr ipts))
 ) ;while
) ;progn
) ;if
(if pts1
(setq objL (subst (append obj2 pts1) obj2 objL))
)
 ) ;repeat

 (if pts
(setq objL (subst (append obj1 pts) obj1 objL))
 ) ;if

) ;repeat
 ;在这里单独去除重合点和点沿曲线排序
(mapcar '(lambda (a)
 (if (cdr a)
(list (car a)
 (gxl-SortPointOnCurve
 (gxl-ListDumpPoint (cdr a) 0.00001)
 (car a)
 )
)
a
 )
 )
 objL
)

) ;defun interss1
;;;========================================================================================
;;;Line/Arc/Circle实体打断程序 Break_ss
(defun Break_ss (ss / ObjptL obj pts
 thisdrawing modelspace ssl
 pstart pend LayerName LinetypeColor
 objLine
 )

(ifss
 (progn
(setq objptL (interss ss)
 thisdrawing (vla-get-activedocument
 (vlax-get-acad-object)
 )
 modelspace(vla-get-ModelSpace thisdrawing)
 ssL (length objptL)
 i -1
)
 ) ;progn
) ;if
(vla-startundomark thisdrawing)
(setq LastEntity (entlast))
(repeat ssl
 (setq objPts (nth (setq i (1+ i)) objptL)
 obj (car objPts)
 pts (cadr objPts)
 )
 (cond ((= (vla-get-objectname obj) "AcDbLine")
 (setq LayerName (vla-get-layer obj)
 Linetype(vla-get-linetype obj)
 Color (vla-get-color obj)
 )
 (setq pstart (vlax-curve-getstartpoint obj)
 pend (vlax-curve-getendpoint obj)
 pts (append (list pstart) pts)
 pts (append pts (list pend))
 )
 (while
 (> (length pts) 1)
(setq objLine (vla-addline
 modelspace
 (vlax-3d-point (car pts))
 (vlax-3d-point (cadr pts))
 )
)
;;;加入选择集
(ssadd (entlast) NewSel)
(vla-put-layer objLine LayerName)
(vla-put-linetype objLine Linetype)
(vla-put-color objLine Color)
(setq pts (cdr pts))
 )
 (ssdel (vlax-vla-object->ename obj) Sel)
 (vla-Delete obj)
 )
 ((= (vla-get-objectname obj) "AcDbArc")
 (BreakArcByPoint (vlax-vla-object->ename obj) pts)
 )
 ((= (vla-get-objectname obj) "AcDbCircle")
 (Cir2ArcByPoint (vlax-vla-object->ename obj) pts)
 )

 ) ;cond

) ;repeat

(vla-endundomark thisdrawing)
) ;defun Break_ss1
;;;将圆、圆弧打断变为arc 实体表转换 (cir2arc cir strang endang)
;;;测试: (cir2arc (car(entsel "\n选择要转为半圆弧的圆实体:")) 0 Pi T)
(defun cir2arc (cir strang endang / el x)
(setq el (entget cir)
el (vl-remove-if
 '(lambda (x) (or (= -1 (car x)) (= 0 (car x))))
 el
 )
el (append
 (list '(0 . "ARC"))
 el
 (list '(100 . "AcDbArc") (cons 50 strang) (cons 51 endang))
 )
)
(entmake el)
;;;加入选择集
(ssadd (entlast) NewSel)
)
;;;沿园上分割点将园打断为圆弧 Cir2ArcByPoint cir ptLst
(defun Cir2ArcByPoint(cir ptLst / cpt r x k kk ang0 ang1 angL)
(setq cpt (dxf cir 10)
r (dxf cir 40)
)
(setq angL (vl-sort (mapcar '(lambda (x) (angle cpt x)) ptLst) '<))
(setq k -1
kk (length angL)
ang0 (last angL)
)
(repeat kk
 (setq ang1 (nth (setq k (1+ k)) angL)
 )
 (cir2arc cir ang0 ang1)
 (setq ang0 ang1)

) ;repeat
(ssdel cir Sel)
(entdel cir)
) ;defun
;;;沿园弧上分割点将园打断为圆弧 BreakArcByPoint cir ptLst
(defun BreakArcByPoint
(cir ptLst / cpt r x k kk angstart angEnd ang1 angL)
(setq angstart (dxf cir 50)
angEnd (dxf cir 51)
cpt (dxf cir 10)
)
(setq angL (mapcar '(lambda (x) (angle cpt x)) ptLst))
(setq k-1
kk (length angL)
)
(repeat kk
 (setq ang1 (nth (setq k (1+ k)) angL)
 )
 (cir2arc cir angstart ang1)
 (setq angstart ang1)

) ;repeat
(cir2arc cir angstart angEnd)
(ssdel cir Sel)
(entdel cir)
) ;defun
;;;gxl-ListDumpPoint 从给定点列表中移去重复出现的点。
;;pts:表fuzz:精度
;;By Aeo
(defun gxl-ListDumpPoint (ptLst fuzz / pt1 x)
(cond ((= (length ptLst) 1) ptLst)
(t
(setq pt1 (car ptLst))
(cons pt1
(vl-remove-if
 '(lambda (x) (equal pt1 x fuzz))
 (gxl-ListDumpPoint (cdr ptLst) fuzz)
)
)
)
)
)
;;;=============================================================================================
;;;(gxl-SortPointOnCurvepoints curve) 参数点集 points 曲线图元 curve 点集沿曲线排序

(defun gxl-SortPointOnCurve (points curve / pl1 xx nn)
(if(= (type curve) 'ENAME)
 (setq curve (vlax-ename->vla-object curve))
)
(setq pl1 (mapcar '(lambda (xx /)
 (vlax-curve-getparamatpoint
 curve
 (vlax-curve-getclosestpointto curve xx)
 )
 )
 points
 )
)
(mapcar '(lambda (nn) (nth nn points))
 (vl-sort-i pl1 '<)
)
)
;;;===============================
;;;表操作函数
;;;判断点 p1 是否在点集PL中，是返回T ，不是返回nil，a为精度
;;;例 (IsInPointList '(1.0001 1.001 0) '((1 1 0) (2 1 0)) 0.001),返回T
(defun IsInPointList (p1 PL a)
(if(member t (mapcar '(lambda (b) (equal p1 b a)) PL))
 t
 nil
)
)
;;;取出图元索引i对应的值
(defun dxf (ent i)
(cdr (assoc i (entget ent)))
)
;;;==================================================================
;;;MidPoint 表操作函数,计算两点的中点
;;;计算两点的中点
;;;==================================================================
(defun MidPoint (p1 p2)
(if(> 2 (length p1))
 (list (* 0.5 (+ (car p1) (car p2)))
 (* 0.5 (+ (cadr p1) (cadr p2)))
 (* 0.5 (+ (caddr p1) (caddr p2)))
 )
 (list (* 0.5 (+ (car p1) (car p2)))
 (* 0.5 (+ (cadr p1) (cadr p2)))
 )
)
)

;;;取圆弧的起点、终点。中点
(defun arc_3point (a / cenp radius STP ENPmp arcmidpoint)
(setq cenp (cdr (assoc 10 (entget a))))
(setq radius (cdr (assoc 40 (entget a))))
(setq
 STP (vlax-curve-getPointAtParam A (vlax-curve-getstartparam A))
)
(setq ENP (vlax-curve-getPointAtParam A (vlax-curve-getEndParam A)))
(setq arcmidpoint
(polar (polar stp
 (angle stp enp)
 (/ (distance STP ENP) 2.0)
 )
 (angle cenp
 (polarstp
 (angle stp enp)
 (/ (distance STP ENP) 2.0)
 )
 )
 (- radius
 (distance (polar stp
 (angle stp enp)
 (/ (distance STP ENP) 2.0)
 )
 cenp
 )
 )
)
)
(list stp enp arcmidpoint)
)
;;;==================================================================
;;;get_rec_pointlist 获得一组点列表中左下角坐标和右上角坐标范围,[<左下角点> <右上角点> ]
;;;==================================================================
(defun get_rec_pointlist (Pt_List / n plx ply pmin pmax e1 e2)
(setq pt3 (LIST (apply 'max (mapcar '(lambda (x) (car X)) PT_LIST))
 (apply 'max (mapcar '(lambda (x) (caDr X)) PT_LIST))
 )
PT1 (LIST (apply 'mIN (mapcar '(lambda (x) (car X)) PT_LIST))
 (apply 'mIN (mapcar '(lambda (x) (caDr X)) PT_LIST))
 )
)
(list PT1
pt3
)
) ;defun get_rec_pointlist
;;;==================================================================
;;;zoom_window 窗口显示，参数，点对表
;;;==================================================================
(defun zoom_window (pl)
(setq n (length pl))
(if(= 2 n)
 (command "_.Zoom" "W" (car pl) (cadr pl))
)
) ;defun zoom_window
;;;==================================================================
;;;返回直线、弧、园中点左右两侧一定距离的点，(LAC-LR-Point en d) 返回点对表（左侧点 . 右侧点）
(defun LAC-LR-Point (en d / a1 a2 a3 ang1 ang2)
(cond ((= (dxf en 0) "LINE")
(setq a1 (dxf en 10)
a2 (dxf en 11)
a3 (MidPoint a1 a2)
ang(angle a1 a2)
ang1 (+ ang (* pi 0.5))
ang2 (- ang (* pi 0.5))
a1 (polar a3 ang1 d)
a2 (polar a3 ang2 d)
)
(cons a1 a2)
)
((= (dxf en 0) "ARC")
(setq a3(dxf en 10);圆心
r (dxf en 40);半径
ang (* (+ (dxf en 50) (dxf en 51)) 0.5)
a1(polar a3 ang (- r d))
a2(polar a3 ang (+ r d))
)
(cons a1 a2)
)
((= (dxf en 0) "CIRCLE")
(setq a1 (dxf en 10)
a2 (polar a1 0 (+ d (dxf en 40)))
)
(cons a1 a2)

)
) ;cond
)

;;;根据选择集中的line、arc、circle，生成点集
(defun make_point_list (s / PL)
(setq n0
PL '()
mn (sslength s)
)
(repeat mn
 (setq en (ssname s n)
 enType (dxf en 0)
 )
 (cond
((= enType "LINE")
(setq pt1 (dxf en 10)
 pt2 (dxf en 11)
)
(if (not (IsInPointList pt1 pl 0.00001))
(setq pl (cons pt1 pl))
) ;if
(if (not (IsInPointList pt2 pl 0.00001))
(setq pl (cons pt2 pl))
) ;if
)
((= enType "ARC")
(setq pt1 (car (arc_3point en))
 pt2 (cadr (arc_3point en))
)
(if (not (IsInPointList pt1 pl 0.00001))
(setq pl (cons pt1 pl))
) ;if
(if (not (IsInPointList pt2 pl 0.00001))
(setq pl (cons pt2 pl))
) ;if

)

 ) ;cond
 (setq n (1+ n))
) ;repeat
(setq pl pl)
) ;make_point_list
;;;=======================================================
;;;主程序开始
(princ "\n*******选择直线园弧园自动生成边界,程序作者：Gu_xl********")
(setq oldos (getvar "osmode"))
(setq oldfill (getvar "fillmode"))
(setvar "osmode" 0)
(setvar "fillmode" 1)
(setvar "cmdecho" 0)
(setq NewSel (ssadd))

(princ "\n选择直线、园弧、园：")
(setq sel (ssget (list '(0 . "line,arc,circle"))))
(princ "\n正在整理数据...........")
;;;打断代码
(Break_ss Sel)
(setq Sel (SS_SSjoin Sel NewSel))

(if sel
(progn

 (setq Plist (make_point_list sel))
 (zoom_window (setq recList (get_rec_pointlist Plist)))
;;;计算点范围Y值的五百分之一
 (setq VerticalLimit
 (* 0.002 (- (cadadr recList) (cadar recList)))
 )
 (if (< VerticalLimit 0.2)
(setq VerticalLimit 0.2)
 )

 (setq enlast (entlast)
 ensel(ssadd)
 )
;;;如果enlast为块定义，得到最后子图元
 (while (entnext enlast)
(setq enlast (entnext enlast))
 )
 (setq enlast1 enlast)

 (command "_.boundary" "a" "i" "n" "+x" "b" "n" sel "" "")
 (setq ki -1
 k(sslength Sel)
 )
 (princ "\n共有 ")
 (princ K)
 (princ " 边，正在生成边界.........")
 (princ K)
 (repeat k
(setq en-line (ssname Sel (setq ki (1+ ki)))
 LpLst (LAC-LR-Point en-line VerticalLimit) ;直线两边点
)
(command (car LpLst))
(command (cdr LpLst))

 ) ;repeat
 (command "")

;;;======================================================
 (while (setq en (entnext enlast))
(setq enlast en)
(ssadd en ensel)
 ) ;while
 (command "erase" sel "")
 (setq ensel ensel)
) ;progn
nil
) ;if
(setvar "osmode" oldos)
(setvar "fillmode" oldfill)
(princ)
)

zhd81617 发表于 2012-3-19 12:25:57

谢谢作者

xiaocaiji 发表于 2024-11-5 16:20:40

Gu_xl 发表于 2010-2-6 18:52
不好意思，该处代码有误，已修改((= enType "ARC")(setq pt1 (car (arc_3point en))pt2 (cadr (arc_3point...

学习下，谢谢

pickstar 发表于 2019-1-20 16:39:49

xuexi

liu_kunlun 发表于 2010-2-5 09:17:00

用手工选择限制选择实体的范围(setq sel (ssget "x" (list '(0 . "line,arc,circle") (cons 8 La))))改为：(setq sel (ssget (list '(0 . "line,arc,circle") (cons 8 La))))

yoyoho 发表于 2010-2-6 09:31:00

Gu_xl 发表于 2010-2-6 18:52:00

Gu_xl 你好:程序对圆弧是不是有问题啊!如果仅选择线是O.K.如果选择含有圆弧时,有错误讯息!ERROR:损坏的引数类型: lentityp nilosnap 目前的物件锁点模式: 端点,中点,中心点,交点 输入物件锁点模式的清单: endp,mid,int,cen 不好意思，该处代码有误，已修改((= enType "ARC") (setq pt1 (car (arc_3point en)) pt2 (cadr (arc_3point en)) )

yoyoho 发表于 2010-2-6 19:38:00

Gu_xl你好:依照你的方式修正程序,程序运行O.K.感谢你的帮忙!

461045462 发表于 2010-12-22 17:58:56

收藏了，下来学习
谢谢楼主的分享

xiaxiang 发表于 2010-12-22 20:01:05

感谢分享，gu_xl

mandala 发表于 2011-2-16 13:26:31

这个东西厉害。感谢版主分享。

xhq1954425 发表于 2011-2-17 05:08:09

下来备用，谢谢分享！

qcw911 发表于 2011-2-17 07:43:31

好程序，下载收藏!

页: [1] 2 3 4 5 6 7 8 9 10

明经CAD社区's Archiver

【Gu_xl】[讨论]根据选择的直线·、圆弧等实体，自动生成有实体围成的所有边界