批量交点打断 支持多段线 <转帖>
;;;=======================[ BreakObjects.lsp ]==============================
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun break_with (ss2brk ss2brkwith self / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair
get_interpts break_obj
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
(vl-load-com)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
(defun ssget->vla-list (ss / i ename lst)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq lst (cons (vlax-ename->vla-object ename) lst))
)
lst
)
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old))
)
(reverse new)
)
;;==============================================================
;;return a list of intersect points
;;==============================================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
))))))
iplist
)
)
;;==============================================================
;;Break entity at break points in list
;;==============================================================
(defun break_obj (ent brkptlst / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2 p2param
)
(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
)
(foreach brkpt brkptlst ;get last entity created via break
; in case multiple breaks
(if brkobjlst
(progn ;if pt not on object x, switch
; objects
(if (not (numberp (vl-catch-all-apply 'vlax-curve-getdistatpoint
(list obj2break brkpt)
)
)
)
(foreach obj brkobjlst ; find the one that pt is on
(if (numberp (vl-catch-all-apply 'vlax-curve-getdistatpoint
(list obj brkpt)
)
)
(setq obj2break obj) ; switch objects
)
)
)
)
) ;handle any objects that can not
; be used with the break command
;using one point, gap of 0.000001
; is used
(cond
((and
(= "SPLINE" enttype) ; only closed splines
(vlax-curve-isclosed obj2break)
)
(setq p1param (vlax-curve-getparamatpoint obj2break brkpt)
p2 (vlax-curve-getpointatparam obj2break (+ p1param 0.000001))
)
(command "._break" obj2break "_non" (trans brkpt 0 1) "_non"
(trans p2 0 1)
)
)
((= "CIRCLE" enttype) ; break the circle
(setq p1param (vlax-curve-getparamatpoint obj2break brkpt)
p2 (vlax-curve-getpointatparam obj2break (+ p1param 0.000001))
)
(command "._break" obj2break "_non" (trans brkpt 0 1) "_non"
(trans p2 0 1)
)
(setq enttype "ARC")
)
((and
(= "ELLIPSE" enttype) ; only closed ellipse
(vlax-curve-isclosed obj2break)
) ;break the ellipse, code borrowed
; from joe burke6/6/2005
(setq p1param (vlax-curve-getparamatpoint obj2break brkpt)
p2param (+ p1param 0.000001)
minparam (min
p1param
p2param
)
maxparam (max
p1param
p2param
)
obj (vlax-ename->vla-object obj2break)
)
(vlax-put obj 'startparameter maxparam)
(vlax-put obj 'endparameter (+ minparam (* pi 2)))
) ; ==================================
(t ; objects that can be broken
(setq closedobj (vlax-curve-isclosed obj2break))
(command "._break" obj2break "_non" (trans brkpt 0 1) "_non"
(trans brkpt 0 1)
)
(if (not closedobj) ; new object was created
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
)
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(if (and ss2brk ss2brkwith)
(progn
;;CREATE a list of entity & it's break points
(foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj (ssget->vla-list ss2brkwith)
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
)
)
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
)
)
)
)
;;masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk))
)
)
)
)
;;==============================================================
)
(princ)
;;==========================================
;; Break all objects selected
;;==========================================
(defun c:breakall (/ cmd ss)
(command ".undo" "begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
;;get objects to break
(prompt "\nSelect All objects to break & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(Break_with ss ss nil) ; ss2break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command ".undo" "end")
(princ)
)
;;==========================================
;;Break a single object with many objects
;;==========================================
(defun c:BreakObject (/ cmd ss1 ss2)
(command ".undo" "begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
;;get objects to break
(prompt "\nSelect single object to break: ")
(if (and (setq ss1 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 3))
(not (prompt "\n***Select object(s) to break with & press enter:***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 4)))
(Break_with ss1 ss2 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command ".undo" "end")
(princ)
)
;;==========================================
;;Break many objects with a single object
;;==========================================
(defun c:breakwobjects (/ cmd ss1 ss2)
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)
(command ".undo" "begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
;;get objects to break
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n***Select single object to break with:***"))
(setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command ".undo" "end")
(princ)
)
;;==========================================
;;Break many objects with many object
;;==========================================
(defun c:BreakWith (/ cmd ss1 ss2)
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)
(command ".undo" "begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
;;get objects to break
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n***Select object(s) to break with & press enter:***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command ".undo" "end")
(princ)
)
;;=============================================
;;Break many objects with a selected objects
;;Selected Objects create ss to be broken
;;=============================================
(defun c:BreakTouching (/ cmd ss1 ss2)
;;get all objects touching entities in the sscross
;;limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
(defun gettouching (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq
ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)
(command ".undo" "begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
;;get objects to break
(if (and (not (prompt "\nSelect object(s) to break with & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss1 ss2 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command ".undo" "end")
(princ)
)
;;==========================================================
;;Break selected objects with any objects that touch it
;;==========================================================
(defun c:BreakSelected (/ cmd ss1 ss2)
;;get all objects touching entities in the sscross
;;limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
(defun gettouching (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq
ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)
(command ".undo" "begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
;;get objects to break
(if (and (not (prompt "\nSelect object(s) to break with & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command ".undo" "end")
(princ)
)
本帖最后由 布朗运动 于 2015-10-30 10:55 编辑
lilq_78 发表于 2014-2-19 15:46 static/image/common/back.gif
顶，但是矩形与矩形相交打断不行
对原程序243-266行代码进行了改进：
;;==========================================
;;Break many objects with many object
;;==========================================
(defun c:BreakWith (/ cmd ss1 ss2)
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)
(command ".undo" "begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq xuanz nil)
;;get objects to break
(prompt "\n选择要打断的直线或多线段，按回车确定: ")
(if (and(setq ss1
(ssget
'((0
.
"LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
)
)
)
xuanz (ssget "P" '((0 . "LWPOLYLINE") (70 . 1)));取出选中的闭合多段线，一般为矩形或多边形命令创建
flag1 (if (/= ss1 nil) T);判断选择集ss1是否非空
)
(not (ssredraw ss1 3))
(not
(prompt
"\n***选择作为打断线的直线或多线段，按回车确定:***"
)
)
(setq
ss2 (ssget
'((0
.
"LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
)
)
)
ssd(ssredraw ss1 4);新增
flag2 (if (/= ss2 nil) T);判断选择集ss2是否非空
)
;(not (ssredraw ss1 4))把该语句放在上面的setq语句群里，避免ss2为nil时本句不被执行的意外情况
)
(progn
(if(/= xuanz nil)
(progn
(setq snum -1)
(repeat (SSLENGTH xuanz)
(setq a (entget (ssname xuanz (setq snum (+ 1 snum)))));取出xuanz中的每个闭合多线段
(setq num (cdr (assoc 90 a))) ;多线段顶点数量
(setq pnum (- (length a) (length (member (assoc 10 a) a))))
;pnum为多线段第一个顶点坐标子列表所在项数（组码10）
(setq qdlst (PARTLIST1 pnum (+ pnum 4) a))
;第一个端点列表
(setq tou (PartList1 0 (- (length a) 2) a))
;原列表去掉最后一个元素后的新列表
(setq zhong (append tou qdlst))
;新列表插入第一个端点坐标
(setq wei (nth (- (length a) 1) a))
;保存原列表最后一个元素
(setq a (append zhong (list wei)))
;加入原列表最后一个元素
(setq a (subst (cons 70 0) (assoc 70 a) a))
;将闭合多线段改为非闭合多线段
(setq a (subst (cons 90 (+ num 1)) (assoc 90 a) a))
;修改多线段顶点个数
(entmod a)
)
)
)
(break_with ss1 ss2 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
)
)
(setvar "CMDECHO" cmd)
(command ".undo" "end")
(princ)
)
其中用到了自贡黄明儒老师发表的函数：
;截取部分列表子函数
(defun PartList1 (from to lst / I L)
(setq i -1)
(foreach x lst
(setq i (1+ i))
(cond ((and (>= i from) (<= i to)) (setq l (cons x l))))
)
(REVERSE l)
) 布朗运动 发表于 2015-10-30 10:54
对原程序243-266行代码进行了改进：
;;==========================================
;;Break...
涉及到矩形打断的时候 矩形的左上角点会被强制断开这点能改下的话 就很好了 非常好的功能，谢谢 c:\\1.gif 类似这个 图谱的功能
看到 论坛有了 就不在录制了
很好的程序，多谢分享！ 看看，学习一下 niu
tai niu le 很给力，谢分享
已经收下！ 很好的程序，多谢分享 确实不错。主要是交点比较多的话，稍微有点慢。
十分感谢。