批量交点打断支持多段线 <转帖>

123523058 · 发表于 2012-5-23 11:17

;;;=======================[ 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 burke 6/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)
)

;;;=======================[ 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 burke  6/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:54

本帖最后由布朗运动于 2015-10-30 10:55 编辑

lilq_78 发表于 2014-2-19 15:46
顶，但是矩形与矩形相交打断不行

对原程序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)
)

guosheyang · 发表于 2021-12-16 09:43

布朗运动发表于 2015-10-30 10:54
对原程序243-266行代码进行了改进：
;;==========================================
;; Break ...

涉及到矩形打断的时候矩形的左上角点会被强制断开这点能改下的话就很好了

magicheno · 发表于 2020-2-29 18:56

非常好的功能，谢谢

123523058 · 发表于 2012-5-23 11:21

c:\\1.gif

123523058 · 发表于 2012-5-23 11:24

类似这个图谱的功能
看到论坛有了就不在录制了

vlisp2012 · 发表于 2012-5-23 17:07

很好的程序，多谢分享！

叮咚 · 发表于 2012-7-1 11:19

看看，学习一下

qwesxqe · 发表于 2012-7-14 23:58

niu
tai niu le

街角的幸福 · 发表于 2012-7-16 20:27

很给力，谢分享

xsso · 发表于 2012-7-16 21:38

已经收下！

woky57 · 发表于 2012-7-17 14:44

很好的程序，多谢分享

yulong爱 · 发表于 2012-8-17 17:16

确实不错。主要是交点比较多的话，稍微有点慢。
十分感谢。

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

批量交点打断支持多段线 <转帖>

评分

本帖子中包含更多资源

批量交点打断 支持多段线 <转帖>

评分

本帖子中包含更多资源

批量交点打断支持多段线 <转帖>