【牢固】多段线剪裁多段线，并重构封闭多段线

牢固 · 发表于 2013-5-17 15:35:31

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由牢固于 2013-7-11 21:52 编辑

此贴为回应批量线（多义线）编程深入探讨（一）中 GTJ116600的问题，重新开贴是为便于收藏！
未标题-1.jpg.thumb.jpg

程序效果！

如果无法播放，请点击此处在新窗口打开

[sell=20]

;;多段线剪裁多段线，并重构封闭多段线 By Gu_xl 2013.05.08
(defun c:trin (/ *error* cmdecho)
(defun *error* (s)
(princ s)
(setvar 'cmdecho cmdecho)
)
(setq cmdecho (getvar 'cmdecho))
(setvar 'cmdecho 0)
(setq en (car(entsel "\n选择多段线")))
;(command "_zoom" "o" en "_zoom" "0.75x")
;;方法1
(trimEdgeIn1 en)
;;方法2
(trimEdgeIn en)
(setvar 'cmdecho cmdecho)
(princ)
)
;;;根据边界剪切多段线，并闭合剪切后的多段线
;;方法1：采用BPoly函数重新构建边界
;;(trimEdgeIn (car(entsel)))
(defun trimEdgeIn1 (ENEDGE / DOC DIS OBJ1 OBJ OBJ2 TMP PL
P1 PPL PPL0 N P01 P02 S1 SS EN P0
PAR0 PAR1 MP A0 A1 I E P2 A
)
(vla-StartUndoMark
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(setq dis (* 0.005 (getvar "viewsize"))) ;_ 拟合间距
(setq obj1 (vlax-invoke
(setq obj (vlax-ename->vla-object ENEDGE))
'offset
dis
)
obj2 (vlax-invoke
(setq obj (vlax-ename->vla-object ENEDGE))
'offset
(- dis)
)
) ;_ 两侧偏移多段线
(setq obj1
(vl-sort obj1
'(lambda (a b) (> (vla-get-area a) (vla-get-area b)))
)
) ;_ 偏移后的多段线按面积从大到小排序，因偏移后可能会有多个多段线
(mapcar 'vla-delete (cdr obj1)) ;_ 保留面积最大的多段线
(setq obj1 (car obj1))
(setq obj2
(vl-sort obj2
'(lambda (a b) (> (vla-get-area a) (vla-get-area b)))
)
)
(mapcar 'vla-delete (cdr obj2))
(setq obj2 (car obj2))
(if (> (vla-get-area obj1)
(vla-get-area obj2)
)
(setq tmp obj1
obj1 obj2
obj2 tmp
)
) ;_ 确保 obj1 为内侧曲线 obj2 为外侧曲线
(setq pl (mapcar '(lambda (x) (trans x 0 1))
(gxl-getpolyptList enEdge dis)
)
) ;_ 计算多段线拟合顶点坐标
(setq ppl (mapcar '(lambda (x) (trans x 0 1))
(gxl-getpolyptList obj1 dis)
)
) ;_ 计算多边形向内偏移dis的顶点坐标
(setq ppl0 (mapcar '(lambda (x) (trans x 0 1))
(gxl-getpolyptList obj2 dis)
)
) ;_ 计算多边形向外偏移dis的顶点坐标
(vla-delete obj1)
(vla-delete obj2)
(setq pl (append pl (list (car pl)))
ppl (append ppl (list (car ppl)))
)
;;开始剪裁
(command "trim" enEdge "")
(setq n 0)
(repeat (1- (length ppl))
(setq p01 (nth n ppl)
p02 (nth (setq n (1+ n)) ppl)
)
(command "f" p01 p02 "")
(command "f" p01 p02 "")
(command "f" p01 p02 "") ;_ 连剪三次，以防剪切不净
)
(command "")
(setq s1 (ssget "wp" pl))
(if s1
(progn
(command "erase" s1 "")
)
) ;_ 删除内部物体
(entdel enEdge) ;_ 隐藏剪裁边界
(setq ss (ssget "f" ppl0 '((0 . "lwpolyline")))) ;_ 选择剪裁后的多段线
(entdel enEdge) ;_ 恢复边界
(if ss
(repeat (setq n (sslength ss)) ;_ 逐个处理剪裁后的多段线
(setq en (ssname ss (setq n (1- n))))
(if (and
(equal (setq p0 (vlax-curve-getStartPoint en))
(vlax-curve-getclosestpointto enEdge p0)
1e-6
)
(equal (setq p1 (vlax-curve-getendPoint en))
(vlax-curve-getclosestpointto enEdge p1)
1e-6
)
) ;_ 剪裁后的多段线起点和终点都落在边界上
(progn
;;以下是采用BPoly函数重新构建边界
(setq par0 (vlax-curve-getParamAtPoint
enEdge
(vlax-curve-getclosestpointto enEdge p0)
) ;_ 起点参数
par1 (vlax-curve-getParamAtPoint
enEdge
(vlax-curve-getclosestpointto enEdge p1)
) ;_ 终点参数
)
(cond
((= 1 (fix (vlax-curve-getEndParam en))) ;_ 剪裁后的多段线只有两个顶点
(setq mp (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p0 p1))
a0 (+ (* 0.5 pi) (angle p0 p1))
a1 (+ (* 0.5 pi) (angle p1 p0))
)
(cond
((progn
(setq i 1)
(while (and (< i 10)
(not (setq e
(bpoly (trans (polar mp a0 (* i dis)) 0 1))
)
)
)
(setq i (1+ i))
)
e
) ;_ 向直线一侧构建边界
(entdel en) ;_ 构建边界成功后删除原多段线
)
((progn
(setq i 1)
(while (and (< i 10)
(not (setq e
(bpoly (trans (polar mp a1 (* i dis)) 0 1))
)
)
)
(setq i (1+ i))
)
e
) ;_ 向直线另一侧构建边界
(entdel en) ;_ 构建边界成功后删除原多段线
)
)
)
(t ;_ 剪裁后的多段线有两个以上顶点
(setq p1 (vlax-curve-getPointAtParam en 1)
p2 (vlax-curve-getPointAtParam en 2)
a0 (angle p1 p0)
a1 (angle p1 p2)
)
(cond
((gxl-CCLOCK
(mapcar 'cdr
(vl-remove-if-not
'(lambda (x) (= 10 (car x)))
(entget en)
)
)
) ;_ 判断曲线为逆时针
(if (< a0 a1)
(setq a0 (+ a0 pi pi))
)
)
(t ;_ 顺时针
(if (< a1 a0)
(setq a1 (+ a1 pi pi))
)
)
)
(setq a (* 0.5 (+ a0 a1))) ;_ 角平分线
(setq i 1)
(while
(and
(< i 10)
(not (setq e (bpoly (trans (polar p1 a (* i dis)) 0 1)))
)
)
(setq i (1+ i))
)
(if e
(entdel en)
)
)
)
)
)
)
)
(vla-EndUndoMark doc)
)
;;;***************** 函数 gxl-Cclock*****************
;;判断顺时针 = nil 逆时针 = t
(defun gxl-CClock (plist)
(if (= 'ename (type plist))
(setq plist
(mapcar
'cdr
(vl-remove-if-not
'(lambda (x)
(= 10 (car x))
)
(entget plist)
)
)
)
)
(not
(minusp
(apply '+
(mapcar
(function
(lambda (a b)
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
plist
(cons (last plist) plist)
)
)
)
)
)
;;用一定长度的线拟合多段线圆弧，计算多段线的顶点坐标
(defun gxl-getpolyptList (ENT FGX / VERTEXSNUM N
SECDEV PLIST D1 D2 D K
D0 PARAM
)
(setq vertexsNum
(fix (vlax-curve-getEndParam ent))
n 0
) ;_ 结束setq
(repeat vertexsNum
(if (setq secdev (vlax-curve-getSecondDeriv ent n))
(if (equal '(0.0 0.0 0.0) secdev 1e-8)
(setq plist (cons (vlax-curve-getPointAtParam ent n) plist))
(progn
(setq d1 (vlax-curve-getdistAtParam ent n)
d2 (vlax-curve-getdistAtParam ent (1+ n))
d (- d2 d1)
k (fix (/ d fgx))
d0 (/ 1.0 (1+ k))
param n
) ;_ 结束setq
(setq plist (cons (vlax-curve-getPointAtParam ent n) plist))
(if (equal d0 1.0 0.001)
(setq plist
(cons (vlax-curve-getPointAtParam ent (+ 0.5 param))
plist
)
)
(repeat k
(setq plist (cons (vlax-curve-getPointAtParam
ent
(setq param (+ param d0))
)
plist
)
)
)
)
) ;_ 结束progn
) ;_ 结束if
)
(setq n (1+ n))
) ;_ 结束repeat
(if (not (vlax-curve-isClosed ent))
(setq plist (cons (vlax-curve-getEndPoint ent) plist))
) ;_ 结束if
(reverse plist)
)
;;;根据边界剪切多段线，并闭合剪切后的多段线
;;方法2：采用曲线取点法重新构建边界
;;(trimEdgeIn (car(entsel)))
(defun trimEdgeIn (ENEDGE / DOC DIS CC OBJ1 OBJ OBJ2
PL PPL PPL0 N P01 P02 S1
SS EN P0 P1 POLYDATA I
BULGES
)
(vla-StartUndoMark
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(setq dis (* 0.005 (getvar "viewsize"))) ;_ 拟合间距
(setq cc (gxl-CClock ENEDGE)) ;_ 是否逆时针
;_ 确保 obj1 为内侧曲线 obj2 为外侧曲线
(setq obj1 (vlax-invoke
(setq obj (vlax-ename->vla-object ENEDGE))
'offset
(if cc (- dis) dis)
)
obj2 (vlax-invoke
(setq obj (vlax-ename->vla-object ENEDGE))
'offset
(if cc dis (- dis))
)
) ;_ 两侧偏移多段线
(setq obj1
(vl-sort obj1
'(lambda (a b) (> (vla-get-area a) (vla-get-area b)))
)
) ;_ 偏移后的多段线按面积从大到小排序，因偏移后可能会有多个多段线
(mapcar 'vla-delete (cdr obj1)) ;_ 保留面积最大的多段线
(setq obj1 (car obj1))
(setq obj2
(vl-sort obj2
'(lambda (a b) (> (vla-get-area a) (vla-get-area b)))
)
)
(mapcar 'vla-delete (cdr obj2))
(setq obj2 (car obj2))
(setq pl (mapcar '(lambda (x) (trans x 0 1))
(gxl-getpolyptList enEdge dis)
)
) ;_ 计算多段线拟合顶点坐标
(setq ppl (mapcar '(lambda (x) (trans x 0 1))
(gxl-getpolyptList obj1 dis)
)
) ;_ 计算多边形向内偏移dis的顶点坐标
(setq ppl0 (mapcar '(lambda (x) (trans x 0 1))
(gxl-getpolyptList obj2 dis)
)
) ;_ 计算多边形向外偏移dis的顶点坐标
(vla-delete obj1)
(vla-delete obj2)
(setq pl (append pl (list (car pl)))
ppl (append ppl (list (car ppl)))
)
;;开始剪裁
(command "trim" enEdge "")
(setq n 0)
(repeat (1- (length ppl))
(setq p01 (nth n ppl)
p02 (nth (setq n (1+ n)) ppl)
)
(command "f" p01 p02 "")
(command "f" p01 p02 "")
(command "f" p01 p02 "") ;_ 连剪三次，以防剪切不净
)
(command "")
(setq s1 (ssget "wp" pl))
(if s1
(progn
(command "erase" s1 "")
)
) ;_ 删除内部物体
(entdel enEdge) ;_ 隐藏剪裁边界
(setq ss (ssget "f" ppl0 '((0 . "lwpolyline")))) ;_ 选择剪裁后的多段线
(entdel enEdge) ;_ 恢复边界
(if ss
(repeat (setq n (sslength ss)) ;_ 逐个处理剪裁后的多段线
(setq en (ssname ss (setq n (1- n))) )
(if (and
(equal (setq p0 (vlax-curve-getStartPoint en))
(vlax-curve-getclosestpointto enEdge p0)
1e-6
)
(equal (setq p1 (vlax-curve-getendPoint en))
(vlax-curve-getclosestpointto enEdge p1)
1e-6
)
) ;_ 剪裁后的多段线起点和终点都落在边界上
(progn
(setq polydata
(GXL-COPYPOLYDATA
ENEDGE
p1
p0
(cond
((gxl-CClock en)
(if cc
nil
t
)
)
(t
(if cc
t
nil
)
)
)
)
)
(setq i (fix (vlax-curve-getEndParam en))
pl (cdar polydata)
bulges (cadr polydata)
obj (vlax-ename->vla-object en)
)
(repeat (1- (length pl))
(vla-setbulge obj i (car bulges))
(setq bulges (cdr bulges)
i (1+ i)
)
(vla-AddVertex obj i (GXL-AX:2DPOINT (car pl)))
(setq pl (cdr pl))
)
(if (car bulges)
(vla-setbulge obj i (car bulges))
)
(vla-put-Closed obj :vlax-true)
(vla-update obj)
)
)
)
)
(vla-EndUndoMark doc)
(princ)
)
;;(gxl-CopyPolyData poly stp enp cw)复制多段线中的一段的数据
;;参数 poly = 多段线 stp = 起点 enp = 终点 cw(当曲线闭合时有效) = t 顺曲线方向 nil = 反之
;;(setq data (gxl-CopyPolyData (car(entsel "\n多段线:")) (getpoint "\n起点:")(getpoint "\n终点:") nil))
;;(gxl-AddLwPolyLineBulge *MODEL-SPACE* (car data) (cadr data) '((62 . 1)))
(defun gxl-CopyPolyData (POLY STP ENP CW / STPAR ENPAR C
P0 I LOOP BULGE PL BULGES
MP B P1 II
)
(if (not (equal STP ENP 1e-6))
(progn
(if (= 'ename (type poly))
(setq poly (vlax-ename->vla-object poly))
)
(setq stp (vlax-curve-getclosestpointto poly stp)
stpar (vlax-curve-getParamAtPoint poly stp)
enp (vlax-curve-getclosestpointto poly enp)
enpar (vlax-curve-getParamAtPoint poly enp)
c (vlax-curve-isClosed poly)
)
(cond
((or (and c cw) ;_ 闭合、顺曲线方向
(and (not c) (< stpar enpar)) ;_ 不闭合顺曲线方向
)
(setq p0 stp
i stpar
loop t
)
(if (<= i enpar (1+ (fix i)))
(setq loop nil)
)
(setq bulge (vla-getbulge poly (fix i)))
(cond
((equal 0 bulge 1e-6) ;_ 直线段
(setq pl (cons p0 pl)
bulges (cons 0 bulges)
)
)
(t ;_ 弧
(setq mp (vlax-curve-getPointAtParam
poly
(* 0.5
(+ i
(if loop
(1+ (fix i))
enpar
)
)
)
) ;_ 弧段中点
b (/ (distance
mp
(GXL-MIDPOINT
stp
(setq p1
(if loop
(vlax-curve-getPointAtParam poly (1+ (fix i)))
enp
)
)
)
)
(distance p0 p1)
0.5
)
)
(if (minusp bulge)
(setq b (- b))
)
(setq pl (cons p0 pl)
bulges (cons b bulges)
)
)
)
(setq i (1+ (fix i))
p0 (vlax-curve-getPointAtParam poly i)
)
(while loop
(if (and c (= i (fix (vlax-curve-getEndParam poly))))
(setq i 0)
)
(cond
((<= i enpar (1+ (fix i)))
(setq loop nil
bulge (vla-getbulge poly (fix i))
p1 enp
ii enpar ;_ 下点参数
)
)
(t
(setq p1 (vlax-curve-getPointAtParam poly (1+ (fix i)))
bulge (vla-getbulge poly i)
ii (1+ i) ;_ 下点参数
)
)
)
(if (not (equal i ii 1e-6))
(cond
((equal 0 bulge 1e-6) ;_ 直线段
(setq pl (cons p0 pl)
bulges (cons 0 bulges)
)
)
(t ;_ 弧线段
(setq mp (vlax-curve-getPointAtParam poly (* 0.5 (+ i ii))) ;_ 弧段中点
b (/ (distance mp (GXL-MIDPOINT p0 p1))
(distance p0 p1)
0.5
)
)
(if (minusp bulge)
(setq b (- b))
)
(setq pl (cons p0 pl)
bulges (cons b bulges)
)
)
)
)
(setq p0 p1
i (1+ i)
)
)
)
(t ;_ 逆曲线方向
(setq p0 stp
i stpar
loop t
)
(if (zerop i) (setq i (fix (vlax-curve-getEndParam poly))))
(if (>= i
enpar
(if (equal i (fix i) 1e-6)
(1- (fix i))
(fix i)
)
)
(setq loop nil)
)
(if (equal i (fix i) 1e-6)
(setq bulge (vla-getbulge poly (1- (fix i))))
(setq bulge (vla-getbulge poly (fix i)))
)
(cond
((equal 0 bulge 1e-6) ;_ 直线段
(setq pl (cons p0 pl)
bulges (cons 0 bulges)
)
)
(t ;_ 弧
(setq mp (vlax-curve-getPointAtParam
poly
(* 0.5
(+ i
(if loop
(if (equal i (fix i) 1e-6)
(1- (fix i))
(fix i)
)
enpar
)
)
)
) ;_ 弧段中点
b (/ (distance
mp
(GXL-MIDPOINT
stp
(setq p1 (if loop
(vlax-curve-getPointAtParam
poly
(if (equal i (fix i) 1e-6)
(1- (fix i))
(fix i)
)
)
enp
)
)
)
)
(distance p0 p1)
0.5
)
)
(if (> bulge 0)
(setq b (- b))
)
(setq pl (cons p0 pl)
bulges (cons b bulges)
)
)
)
(setq i (if (equal i (fix i) 1e-6)
(1- (fix i))
(fix i)
)
p0 (vlax-curve-getPointAtParam poly i)
)
(while loop
(if (and c (= i 0))
(setq i (fix (vlax-curve-getendParam poly)))
)
(cond
((>= i enpar (1- (fix i)))
(setq loop nil
bulge (vla-getbulge poly (1- (fix i)))
p1 enp
ii enpar ;_ 下点参数
)
)
(t
(setq p1 (vlax-curve-getPointAtParam poly (1- (fix i)))
bulge (vla-getbulge poly (1- (fix i)))
ii (1- (fix i)) ;_ 下点参数
)
)
)
(cond
((equal 0 bulge 1e-6) ;_ 直线段
(setq pl (cons p0 pl)
bulges (cons 0 bulges)
)
)
(t ;_ 弧线段
(setq mp (vlax-curve-getPointAtParam poly (* 0.5 (+ i ii))) ;_ 弧段中点
b (/ (distance mp (GXL-MIDPOINT p0 p1))
(distance p0 p1)
0.5
)
)
(if (> bulge 0)
(setq b (- b))
)
(setq pl (cons p0 pl)
bulges (cons b bulges)
)
)
)
(setq p0 p1
i (1- i)
)
)
)
)
(list (reverse (cons enp pl)) (reverse bulges))
)
)
)
;;;==================================================================
;;;gxl-MidPoint 表操作函数,计算两点的中点
;;;计算两点的中点
;;;==================================================================
(defun gxl-MidPoint (p1 p2)
(mapcar '(lambda (x) (* x 0.5)) (mapcar '+ p1 p2))
);;;gxl-2D-Point 转换一个AutoLISP点到一个二维ActiveX点
(defun gxl-2D-Point (pt)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 1))
(list (car pt) (cadr pt))
)
)
)

;;多段线剪裁多段线，并重构封闭多段线 By Gu_xl 2013.05.08 
(defun c:trin (/ *error* cmdecho) 
  (defun *error* (s) 
    (princ s) 
    (setvar 'cmdecho cmdecho) 
    ) 
  (setq cmdecho (getvar 'cmdecho)) 
  (setvar 'cmdecho 0) 
  (setq en (car(entsel "\n选择多段线"))) 
  ;(command "_zoom" "o" en  "_zoom" "0.75x") 
  ;;方法1 
  (trimEdgeIn1 en) 
  ;;方法2 
  (trimEdgeIn en) 
  (setvar 'cmdecho cmdecho) 
  (princ) 
  ) 
 
;;;根据边界剪切多段线，并闭合剪切后的多段线 
;;方法1：采用BPoly函数重新构建边界 
;;(trimEdgeIn (car(entsel))) 
(defun trimEdgeIn1 (ENEDGE    /          DOC  DIS  OBJ1 OBJ  OBJ2 TMP        PL 
                   P1        PPL  PPL0 N    P01  P02         S1   SS   EN        P0 
                   PAR0        PAR1 MP          A0   A1   I         E    P2   A 
                  ) 
  (vla-StartUndoMark 
    (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) 
  ) 
  (setq dis (* 0.005 (getvar "viewsize"))) ;_ 拟合间距 
  (setq        obj1 (vlax-invoke 
               (setq obj (vlax-ename->vla-object ENEDGE)) 
               'offset 
               dis 
             ) 
        obj2 (vlax-invoke 
               (setq obj (vlax-ename->vla-object ENEDGE)) 
               'offset 
               (- dis) 
             ) 
  ) ;_ 两侧偏移多段线 
  (setq        obj1 
         (vl-sort obj1 
                  '(lambda (a b) (> (vla-get-area a) (vla-get-area b))) 
         ) 
  ) ;_ 偏移后的多段线按面积从大到小排序，因偏移后可能会有多个多段线 
  (mapcar 'vla-delete (cdr obj1)) ;_ 保留面积最大的多段线 
  (setq obj1 (car obj1)) 
  (setq        obj2 
         (vl-sort obj2 
                  '(lambda (a b) (> (vla-get-area a) (vla-get-area b))) 
         ) 
  ) 
  (mapcar 'vla-delete (cdr obj2)) 
  (setq obj2 (car obj2)) 
  (if (> (vla-get-area obj1) 
         (vla-get-area obj2) 
      ) 
    (setq tmp  obj1 
          obj1 obj2 
          obj2 tmp 
    ) 
  ) ;_ 确保 obj1 为内侧曲线 obj2 为外侧曲线 
  (setq        pl (mapcar '(lambda (x) (trans x 0 1)) 
                   (gxl-getpolyptList enEdge dis) 
           ) 
  ) ;_ 计算多段线拟合顶点坐标 
  (setq        ppl (mapcar '(lambda (x) (trans x 0 1)) 
                    (gxl-getpolyptList obj1 dis) 
            ) 
  ) ;_ 计算多边形向内偏移dis的顶点坐标 
  (setq        ppl0 (mapcar '(lambda (x) (trans x 0 1)) 
                     (gxl-getpolyptList obj2 dis) 
             ) 
  ) ;_ 计算多边形向外偏移dis的顶点坐标 
  (vla-delete obj1) 
  (vla-delete obj2) 
  (setq        pl  (append pl (list (car pl))) 
        ppl (append ppl (list (car ppl))) 
  ) 
  ;;开始剪裁 
  (command "trim" enEdge "") 
  (setq n 0) 
  (repeat (1- (length ppl)) 
    (setq p01 (nth n ppl) 
          p02 (nth (setq n (1+ n)) ppl) 
    ) 
    (command "f" p01 p02 "") 
    (command "f" p01 p02 "") 
    (command "f" p01 p02 "") ;_ 连剪三次，以防剪切不净 
  ) 
  (command "") 
  (setq s1 (ssget "wp" pl)) 
  (if s1 
    (progn 
      (command "erase" s1 "") 
    ) 
  ) ;_ 删除内部物体 
  (entdel enEdge) ;_ 隐藏剪裁边界 
  (setq ss (ssget "f" ppl0 '((0 . "lwpolyline")))) ;_ 选择剪裁后的多段线 
  (entdel enEdge) ;_ 恢复边界 
  (if ss 
    (repeat (setq n (sslength ss)) ;_ 逐个处理剪裁后的多段线 
      (setq en (ssname ss (setq n (1- n)))) 
      (if (and 
            (equal (setq p0 (vlax-curve-getStartPoint en)) 
                   (vlax-curve-getclosestpointto enEdge p0) 
                   1e-6 
            ) 
            (equal (setq p1 (vlax-curve-getendPoint en)) 
                   (vlax-curve-getclosestpointto enEdge p1) 
                   1e-6 
            ) 
          ) ;_ 剪裁后的多段线起点和终点都落在边界上 
        (progn 
          ;;以下是采用BPoly函数重新构建边界 
          (setq        par0 (vlax-curve-getParamAtPoint 
                       enEdge 
                       (vlax-curve-getclosestpointto enEdge p0) 
                     ) ;_ 起点参数 
                par1 (vlax-curve-getParamAtPoint 
                       enEdge 
                       (vlax-curve-getclosestpointto enEdge p1) 
                     ) ;_ 终点参数 
          ) 
          (cond 
            ((= 1 (fix (vlax-curve-getEndParam en))) ;_ 剪裁后的多段线只有两个顶点 
             (setq mp (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p0 p1)) 
                   a0 (+ (* 0.5 pi) (angle p0 p1)) 
                   a1 (+ (* 0.5 pi) (angle p1 p0)) 
             ) 
             (cond   
               ((progn 
                  (setq i 1) 
                  (while (and (
                              (not (setq e 
                                          (bpoly (trans (polar mp a0 (* i dis)) 0 1)) 
                                   ) 
                              ) 
                         ) 
                    (setq i (1+ i)) 
                  ) 
                  e 
                ) ;_ 向直线一侧构建边界 
                (entdel en) ;_ 构建边界成功后删除原多段线 
               ) 
               ((progn 
                  (setq i 1) 
                  (while (and (
                              (not (setq e 
                                          (bpoly (trans (polar mp a1 (* i dis)) 0 1)) 
                                   ) 
                              ) 
                         ) 
                    (setq i (1+ i)) 
                  ) 
                  e 
                ) ;_ 向直线另一侧构建边界 
                (entdel en) ;_ 构建边界成功后删除原多段线 
               ) 
             ) 
            ) 
            (t ;_ 剪裁后的多段线有两个以上顶点 
             (setq p1 (vlax-curve-getPointAtParam en 1) 
                   p2 (vlax-curve-getPointAtParam en 2) 
                   a0 (angle p1 p0) 
                   a1 (angle p1 p2) 
             ) 
             (cond 
               ((gxl-CCLOCK 
                  (mapcar 'cdr 
                          (vl-remove-if-not 
                            '(lambda (x) (= 10 (car x))) 
                            (entget en) 
                          ) 
                  ) 
                ) ;_ 判断曲线为逆时针 
                (if (< a0 a1) 
                  (setq a0 (+ a0 pi pi)) 
                ) 
               ) 
               (t ;_ 顺时针 
                (if (< a1 a0) 
                  (setq a1 (+ a1 pi pi)) 
                ) 
               ) 
             ) 
             (setq a (* 0.5 (+ a0 a1))) ;_ 角平分线 
             (setq i 1) 
             (while 
               (and 
                 (
                 (not (setq e (bpoly (trans (polar p1 a (* i dis)) 0 1))) 
                 ) 
               ) 
                (setq i (1+ i)) 
             ) 
             (if e 
               (entdel en) 
             ) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (vla-EndUndoMark doc) 
 
) 
;;;***************** 函数 gxl-Cclock***************** 
;;判断顺时针 = nil 逆时针 = t 
(defun gxl-CClock (plist) 
  (if (= 'ename (type plist)) 
    (setq plist 
           (mapcar 
             'cdr 
             (vl-remove-if-not 
               '(lambda (x) 
                  (= 10 (car x)) 
                  ) 
               (entget plist) 
               ) 
             ) 
          ) 
    ) 
  (not 
            (minusp 
              (apply '+ 
                     (mapcar 
                       (function 
                         (lambda (a b) 
                           (- (* (car b) (cadr a)) (* (car a) (cadr b))) 
                         ) 
                       ) 
                       plist 
                       (cons (last plist) plist) 
                     ) 
              ) 
            ) 
          ) 
  ) 
;;用一定长度的线拟合多段线圆弧，计算多段线的顶点坐标 
(defun gxl-getpolyptList (ENT    FGX           /          VERTEXSNUM        N 
                             SECDEV PLIST  D1          D2         D        K 
                             D0            PARAM 
                            ) 
  (setq        vertexsNum 
         (fix (vlax-curve-getEndParam ent)) 
        n 0 
  ) ;_ 结束setq 
  (repeat vertexsNum 
    (if        (setq secdev (vlax-curve-getSecondDeriv ent n)) 
      (if (equal '(0.0 0.0 0.0) secdev 1e-8) 
        (setq plist (cons (vlax-curve-getPointAtParam ent n) plist)) 
        (progn 
          (setq        d1    (vlax-curve-getdistAtParam ent n) 
                d2    (vlax-curve-getdistAtParam ent (1+ n)) 
                d     (- d2 d1) 
                k     (fix (/ d fgx)) 
                d0    (/ 1.0 (1+ k)) 
                param n 
          ) ;_ 结束setq 
          (setq plist (cons (vlax-curve-getPointAtParam ent n) plist)) 
          (if (equal d0 1.0 0.001) 
            (setq plist 
                   (cons (vlax-curve-getPointAtParam ent (+ 0.5 param)) 
                         plist 
                   ) 
            ) 
            (repeat k 
              (setq plist (cons        (vlax-curve-getPointAtParam 
                                  ent 
                                  (setq param (+ param d0)) 
                                ) 
                                plist 
                          ) 
              ) 
            ) 
          ) 
        ) ;_ 结束progn 
      ) ;_ 结束if 
    ) 
    (setq n (1+ n)) 
  ) ;_ 结束repeat 
  (if (not (vlax-curve-isClosed ent)) 
    (setq plist (cons (vlax-curve-getEndPoint ent) plist)) 
  ) ;_ 结束if 
  (reverse plist) 
) 
;;;根据边界剪切多段线，并闭合剪切后的多段线 
;;方法2：采用曲线取点法重新构建边界 
;;(trimEdgeIn (car(entsel))) 
(defun trimEdgeIn (ENEDGE /        DOC   DIS   CC          OBJ1        OBJ   OBJ2 
                          PL        PPL   PPL0  N          P01        P02   S1 
                          SS        EN    P0    P1          POLYDATA    I 
                          BULGES 
                         ) 
  (vla-StartUndoMark 
    (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) 
  ) 
  (setq dis (* 0.005 (getvar "viewsize"))) ;_ 拟合间距 
  (setq cc (gxl-CClock ENEDGE)) ;_ 是否逆时针 
  ;_ 确保 obj1 为内侧曲线 obj2 为外侧曲线 
  (setq        obj1 (vlax-invoke 
               (setq obj (vlax-ename->vla-object ENEDGE)) 
               'offset 
               (if cc (- dis) dis) 
             ) 
        obj2 (vlax-invoke 
               (setq obj (vlax-ename->vla-object ENEDGE)) 
               'offset 
               (if cc  dis (- dis)) 
             ) 
  ) ;_ 两侧偏移多段线 
  (setq        obj1 
         (vl-sort obj1 
                  '(lambda (a b) (> (vla-get-area a) (vla-get-area b))) 
         ) 
  ) ;_ 偏移后的多段线按面积从大到小排序，因偏移后可能会有多个多段线 
  (mapcar 'vla-delete (cdr obj1)) ;_ 保留面积最大的多段线 
  (setq obj1 (car obj1)) 
  (setq        obj2 
         (vl-sort obj2 
                  '(lambda (a b) (> (vla-get-area a) (vla-get-area b))) 
         ) 
  ) 
  (mapcar 'vla-delete (cdr obj2)) 
  (setq obj2 (car obj2)) 
 
  (setq        pl (mapcar '(lambda (x) (trans x 0 1)) 
                   (gxl-getpolyptList enEdge dis) 
           ) 
  ) ;_ 计算多段线拟合顶点坐标 
  (setq        ppl (mapcar '(lambda (x) (trans x 0 1)) 
                    (gxl-getpolyptList obj1 dis) 
            ) 
  ) ;_ 计算多边形向内偏移dis的顶点坐标 
  (setq        ppl0 (mapcar '(lambda (x) (trans x 0 1)) 
                     (gxl-getpolyptList obj2 dis) 
             ) 
  ) ;_ 计算多边形向外偏移dis的顶点坐标 
  (vla-delete obj1) 
  (vla-delete obj2) 
  (setq        pl  (append pl (list (car pl))) 
        ppl (append ppl (list (car ppl))) 
  ) 
  ;;开始剪裁 
  (command "trim" enEdge "") 
  (setq n 0) 
  (repeat (1- (length ppl)) 
    (setq p01 (nth n ppl) 
          p02 (nth (setq n (1+ n)) ppl) 
    ) 
    (command "f" p01 p02 "") 
    (command "f" p01 p02 "") 
    (command "f" p01 p02 "") ;_ 连剪三次，以防剪切不净 
  ) 
  (command "") 
  (setq s1 (ssget "wp" pl)) 
  (if s1 
    (progn 
      (command "erase" s1 "") 
    ) 
  ) ;_ 删除内部物体 
  (entdel enEdge) ;_ 隐藏剪裁边界 
  (setq ss (ssget "f" ppl0 '((0 . "lwpolyline")))) ;_ 选择剪裁后的多段线 
  (entdel enEdge) ;_ 恢复边界 
  (if ss 
    (repeat (setq n (sslength ss)) ;_ 逐个处理剪裁后的多段线 
      (setq en (ssname ss (setq n (1- n))) ) 
      (if (and 
            (equal (setq p0 (vlax-curve-getStartPoint en)) 
                   (vlax-curve-getclosestpointto enEdge p0) 
                   1e-6 
            ) 
            (equal (setq p1 (vlax-curve-getendPoint en)) 
                   (vlax-curve-getclosestpointto enEdge p1) 
                   1e-6 
            ) 
          ) ;_ 剪裁后的多段线起点和终点都落在边界上 
        (progn 
          (setq        polydata 
                 (GXL-COPYPOLYDATA 
                   ENEDGE 
                   p1 
                   p0 
                   (cond 
                     ((gxl-CClock en) 
                      (if cc 
                        nil 
                        t 
                      ) 
                     ) 
                     (t 
                      (if cc 
                        t 
                        nil 
                      ) 
                     ) 
                   ) 
                 ) 
          ) 
          (setq i (fix (vlax-curve-getEndParam en)) 
                pl (cdar polydata) 
                bulges (cadr polydata) 
                obj (vlax-ename->vla-object en) 
                ) 
          (repeat (1- (length pl)) 
            (vla-setbulge obj i (car bulges)) 
            (setq bulges (cdr bulges) 
                  i (1+ i) 
                  ) 
            (vla-AddVertex obj i (GXL-AX:2DPOINT (car pl))) 
            (setq pl (cdr pl)) 
            ) 
          (if (car bulges) 
          (vla-setbulge  obj i (car bulges)) 
            ) 
          (vla-put-Closed obj :vlax-true) 
          (vla-update obj) 
          ) 
      ) 
    ) 
  ) 
  (vla-EndUndoMark doc) 
(princ) 
) 
;;(gxl-CopyPolyData poly stp enp cw)复制多段线中的一段的数据 
;;参数 poly = 多段线 stp = 起点 enp = 终点 cw(当曲线闭合时有效) = t 顺曲线方向 nil = 反之 
;;(setq data (gxl-CopyPolyData (car(entsel "\n多段线:")) (getpoint "\n起点:")(getpoint "\n终点:") nil)) 
;;(gxl-AddLwPolyLineBulge *MODEL-SPACE* (car data) (cadr data) '((62 . 1))) 
(defun gxl-CopyPolyData        (POLY STP   ENP          CW        /     STPAR ENPAR C 
                              P0    I          LOOP        BULGE PL    BULGES 
                              MP    B          P1        II 
                             ) 
  (if (not (equal STP   ENP 1e-6)) 
    (progn 
  (if (= 'ename (type poly)) 
    (setq poly (vlax-ename->vla-object poly)) 
  ) 
  (setq        stp   (vlax-curve-getclosestpointto poly stp) 
        stpar (vlax-curve-getParamAtPoint poly stp) 
        enp   (vlax-curve-getclosestpointto poly enp) 
        enpar (vlax-curve-getParamAtPoint poly enp) 
        c     (vlax-curve-isClosed poly) 
  ) 
 
  (cond 
    ((or (and c cw) ;_ 闭合、顺曲线方向 
         (and (not c) (< stpar enpar)) ;_ 不闭合顺曲线方向 
     ) 
     (setq p0 stp 
           i stpar 
           loop        t 
     ) 
     (if (<= i enpar (1+ (fix i))) 
       (setq loop nil) 
     ) 
     (setq bulge (vla-getbulge poly (fix i))) 
     (cond 
       ((equal 0 bulge 1e-6) ;_ 直线段 
        (setq pl     (cons p0 pl) 
              bulges (cons 0 bulges) 
        ) 
       ) 
       (t ;_ 弧 
        (setq mp (vlax-curve-getPointAtParam 
                   poly 
                   (* 0.5 
                      (+ i 
                         (if loop 
                           (1+ (fix i)) 
                           enpar 
                         ) 
                      ) 
                   ) 
                 ) ;_ 弧段中点 
              b         (/ (distance 
                      mp 
                      (GXL-MIDPOINT 
                        stp 
                        (setq p1 
                               (if loop 
                                 (vlax-curve-getPointAtParam poly (1+ (fix i))) 
                                 enp 
                               ) 
                        ) 
                      ) 
                    ) 
                    (distance p0 p1) 
                    0.5 
                 ) 
        ) 
        (if (minusp bulge) 
          (setq b (- b)) 
        ) 
        (setq pl     (cons p0 pl) 
              bulges (cons b bulges) 
        ) 
       ) 
     ) 
     (setq i  (1+ (fix i)) 
           p0 (vlax-curve-getPointAtParam poly i) 
     ) 
     (while loop 
       (if (and c (= i (fix (vlax-curve-getEndParam poly)))) 
         (setq i 0) 
       ) 
       (cond 
         ((<= i enpar (1+ (fix i))) 
          (setq        loop  nil 
                bulge (vla-getbulge poly (fix i)) 
                p1    enp 
                ii    enpar ;_ 下点参数 
          ) 
         ) 
         (t 
          (setq        p1    (vlax-curve-getPointAtParam poly (1+ (fix i))) 
                bulge (vla-getbulge poly i) 
                ii    (1+ i) ;_ 下点参数 
          ) 
         ) 
       ) 
       (if (not (equal i ii 1e-6)) 
       (cond 
         ((equal 0 bulge 1e-6) ;_ 直线段 
          (setq        pl     (cons p0 pl) 
                bulges (cons 0 bulges) 
          ) 
         ) 
         (t ;_ 弧线段 
          (setq        mp (vlax-curve-getPointAtParam poly (* 0.5 (+ i ii))) ;_ 弧段中点 
                b  (/ (distance mp (GXL-MIDPOINT p0 p1)) 
                      (distance p0 p1) 
                      0.5 
                   ) 
          ) 
          (if (minusp bulge) 
            (setq b (- b)) 
          ) 
          (setq        pl     (cons p0 pl) 
                bulges (cons b bulges) 
          ) 
         ) 
       ) 
         ) 
       (setq p0        p1 
             i        (1+ i) 
       ) 
     ) 
    ) 
    (t ;_ 逆曲线方向 
     (setq p0 stp 
           i stpar 
           loop        t 
     ) 
     (if (zerop i) (setq i (fix (vlax-curve-getEndParam poly)))) 
     (if (>= i 
             enpar 
             (if (equal i (fix i) 1e-6) 
               (1- (fix i)) 
               (fix i) 
             ) 
         ) 
       (setq loop nil) 
     ) 
     (if (equal i (fix i) 1e-6) 
       (setq bulge (vla-getbulge poly (1- (fix i)))) 
       (setq bulge (vla-getbulge poly (fix i))) 
     ) 
     (cond 
       ((equal 0 bulge 1e-6) ;_ 直线段 
        (setq pl     (cons p0 pl) 
              bulges (cons 0 bulges) 
        ) 
       ) 
       (t ;_ 弧 
        (setq mp (vlax-curve-getPointAtParam 
                   poly 
                   (* 0.5 
                      (+ i 
                         (if loop 
                           (if (equal i (fix i) 1e-6) 
                             (1- (fix i)) 
                             (fix i) 
                           ) 
                           enpar 
                         ) 
                      ) 
                   ) 
                 ) ;_ 弧段中点 
              b         (/ (distance 
                      mp 
                      (GXL-MIDPOINT 
                        stp 
                        (setq p1 (if loop 
                                   (vlax-curve-getPointAtParam 
                                     poly 
                                     (if (equal i (fix i) 1e-6) 
                                       (1- (fix i)) 
                                       (fix i) 
                                     ) 
                                   ) 
                                   enp 
                                 ) 
                        ) 
                      ) 
                    ) 
                    (distance p0 p1) 
                    0.5 
                 ) 
        ) 
        (if (> bulge 0) 
          (setq b (- b)) 
        ) 
        (setq pl     (cons p0 pl) 
              bulges (cons b bulges) 
        ) 
       ) 
     ) 
     (setq i  (if (equal i (fix i) 1e-6) 
                (1- (fix i)) 
                (fix i) 
              ) 
           p0 (vlax-curve-getPointAtParam poly i) 
     ) 
     (while loop 
       (if (and c (= i 0)) 
         (setq i (fix (vlax-curve-getendParam poly))) 
       ) 
       (cond 
         ((>= i enpar (1- (fix i))) 
          (setq        loop  nil 
                bulge (vla-getbulge poly (1- (fix i))) 
                p1    enp 
                ii    enpar ;_ 下点参数 
          ) 
         ) 
         (t 
          (setq        p1    (vlax-curve-getPointAtParam poly (1- (fix i))) 
                bulge (vla-getbulge poly (1- (fix i))) 
                ii    (1- (fix i)) ;_ 下点参数 
          ) 
         ) 
       ) 
       (cond 
         ((equal 0 bulge 1e-6) ;_ 直线段 
          (setq        pl     (cons p0 pl) 
                bulges (cons 0 bulges) 
          ) 
         ) 
         (t ;_ 弧线段 
          (setq        mp (vlax-curve-getPointAtParam poly (* 0.5 (+ i ii))) ;_ 弧段中点 
                b  (/ (distance mp (GXL-MIDPOINT p0 p1)) 
                      (distance p0 p1) 
                      0.5 
                   ) 
          ) 
          (if (> bulge 0) 
            (setq b (- b)) 
          ) 
          (setq        pl     (cons p0 pl) 
                bulges (cons b bulges) 
          ) 
         ) 
       ) 
       (setq p0        p1 
             i        (1- i) 
       ) 
     ) 
 
 
    ) 
  ) 
  (list (reverse (cons enp pl)) (reverse bulges)) 
  ) 
    ) 
) 
;;;================================================================== 
;;;gxl-MidPoint 表操作函数,计算两点的中点 
;;;计算两点的中点 
;;;================================================================== 
(defun gxl-MidPoint (p1 p2) 
  (mapcar '(lambda (x) (* x 0.5)) (mapcar '+ p1 p2)) 
  );;;gxl-2D-Point 转换一个AutoLISP点到一个二维ActiveX点 
(defun gxl-2D-Point (pt) 
  (vlax-make-variant 
    (vlax-safearray-fill 
      (vlax-make-safearray vlax-vbdouble '(0 . 1)) 
      (list (car pt) (cadr pt)) 
    ) 
  ) 
)

[/sell]
用晓东API来写该功能，寥寥几句代码就可以搞定：（2013.07.11）

(defun c:tt ()
(xdrx_begin (list "cmdecho" 0 "osmode" 0))
(xdrx_document_ucson)
(setq poly (car (xdrx_entsel "\n选择多段线:" '((0 . "lwpolyline")))))
(if poly
(progn
(vla-copy (vlax-ename->vla-object poly))
;;返回多段线的模拟点
(setq pts (xdrx_getsamplept poly))
;;返回向内偏移的的顶点坐标
(setq pts1 (xdrx_curve_offset poly (* -0.005 (getvar 'viewsize))))
;;隐藏原边界
(redraw poly 0)
(setq ss (ssget "_F" pts '((0 . "*polyline"))))
;;曲线交点打断
(setq ss (XDRX_CURVE_INTERSECTBREAK ss 0))
;;如果不加延迟，后面选择不到多段线
(command "delay" 100)
;;删除边界内多段线
(setq s1 (ssget "wp" pts '((0 . "*polyline"))))
(if s1 (command "erase" s1 ""))
(setq s1 (ssget "_F" pts1 '((0 . "*polyline"))))
(if s1 (command "erase" s1 ""))
(setq ss (XDRX_CURVE->REGION ss))
(xdrx_document_ucsoff)
;;恢复原边界
(redraw poly 1)
)
)
(xdrx_end)
)

(defun c:tt () 
  (xdrx_begin (list "cmdecho" 0 "osmode" 0)) 
  (xdrx_document_ucson) 
  (setq poly (car (xdrx_entsel "\n选择多段线:" '((0 . "lwpolyline"))))) 
  (if poly 
    (progn 
      (vla-copy (vlax-ename->vla-object poly)) 
      ;;返回多段线的模拟点 
      (setq pts (xdrx_getsamplept poly)) 
      ;;返回向内偏移的的顶点坐标 
      (setq pts1 (xdrx_curve_offset poly (* -0.005 (getvar 'viewsize)))) 
      ;;隐藏原边界 
      (redraw poly 0) 
      (setq ss (ssget "_F" pts '((0 . "*polyline")))) 
      ;;曲线交点打断 
      (setq ss (XDRX_CURVE_INTERSECTBREAK ss 0)) 
      ;;如果不加延迟，后面选择不到多段线 
      (command "delay" 100) 
      ;;删除边界内多段线 
      (setq s1 (ssget "wp" pts '((0 . "*polyline")))) 
      (if s1 (command "erase" s1 "")) 
      (setq s1 (ssget "_F" pts1 '((0 . "*polyline")))) 
      (if s1 (command "erase" s1 "")) 
      (setq ss (XDRX_CURVE->REGION ss)) 
       (xdrx_document_ucsoff) 
      ;;恢复原边界 
      (redraw poly 1) 
       
      ) 
    ) 
  (xdrx_end) 
  )

裸奔的花猫 · 发表于 2013-5-17 17:07:27

相当于ET工具的图形切割

haoryh · 发表于 2013-5-17 18:35:33

老大这个利害！

429014673 · 发表于 2013-5-17 19:08:50

好贵，就是没什么钱，还实用吧

kwok · 发表于 2013-5-17 19:12:23

好，下来学习一下.

菜菜学ODCL · 发表于 2013-5-17 23:52:33

老大去哪我去哪，老大，程序是用BPOLY生成的边界不？

sicky111 · 发表于 2013-5-18 01:04:34

G版的程式，一定要看，能学到很多东西。

429014673 · 发表于 2013-5-22 22:03:40

好像可以看得见剪切刀

adc · 发表于 2013-5-23 13:38:02

支持{:soso_e100:}

sicky111 · 发表于 2013-5-23 22:42:12

可以剪切，但提示缺少GXL-COPYPOLYDATA函数。

牢固 · 发表于 2013-5-23 22:56:50

sicky111 发表于 2013-5-23 22:42
可以剪切，但提示缺少GXL-COPYPOLYDATA函数。

函数补上了！请重新下载！

sicky111 · 发表于 2013-5-23 23:22:36

谢谢，我再试下。

HLCAD · 发表于 2013-5-24 10:13:20

本帖最后由 USER2128 于 2013-5-24 14:15 编辑

程序试用手记：
方法1（采用BPoly函数重新构建边界）不能达到预期效果，现只用方法2；
方法1和方法2中针对剪裁含虚线、中心线等线型时，会漏剪（还没想到最佳方法）；
用多段线剪裁全直线时，会有少部分外围线也剪掉了（或删除了）;
用未封闭多段线剪裁时，与多段线缺口相交线部分全删除了（也许就是要这种要求），
程序中缺少子函数“GXL-AX:2DPOINT”（但运行时并未报错）。

pengfei2010 · 发表于 2013-5-25 14:25:05

这个应该属于技巧性程序，目前还未社稷到

HLCAD · 发表于 2013-5-25 14:46:17

本帖最后由 USER2128 于 2013-5-25 15:14 编辑

“no function definition: GXL-AX:2DPOINT”
缺少函数：GXL-AX:2DPOINT，望楼主补上
被切断后的多段线能够分成两段，如果是在多段线闭合区段时的那一边，被切多段线不能闭合
另：首尾端点闭合（而不是“PEDIT” “CL”闭合），则程序运行报错

账号		自动登录	找回密码
密码			立即注册

[每日一码] 【牢固】多段线剪裁多段线，并重构封闭多段线

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

本帖被以下淘专辑推荐:

点评

评分

点评