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

;;;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))))
    ;;(setq sel (ssget (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
)   
;;程序缺点是选择的实体多了，计算速度太慢，请高手讨论，提供共好的算法！
;;程序加以改进后，完整代码如下：
;;以下内容需要发帖数高于 10 才可浏览
;;;选择直线 园弧 园自动生成边界,程序作者：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)
        (if  ss1
            (progn
                (if (= (type ss1) 'ENAME)
                    (progn
                        (setq
                            ename ss1
                            ss1   (ssadd)
                        )
                        (ssadd ename ss1)
                    )
                )
            )
        )
        (if  ss2
            (progn
                (if (= (type ss2) 'ENAME)
                    (progn
                        (setq
                            ename ss2
                            ss2   (ssadd)
                        )
                        (ssadd ename ss2)
                    )
                )
            )
        )
        (setq ss (ssadd))
        (if  (and ss1 ss2)
            (progn
                (setq ss  ss2
                    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 Linetype  Color
                                        objLine
                                    )
        (if  ss
            (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-SortPointOnCurve  points 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
                    (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)
    )
    ;;;==================================================================
    ;;;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 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
    ;;;=======================================================
    ;;;主程序开始
    (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)
)