[编程交流] 单触并断开int

(setq epoly(entsel))
  (setq PIKPT (cadr EPOLY))
   (setq  ENXT (entnext (car EPOLY)))
    (setq LST (entget ENXT))
     (setq P1 (cdr(assoc 10 LST)))
     (setq ENXT (entnext ENXT))
     (setq LST (entget ENXT))
     (setq P2 (cdr(assoc 10 LST)))
 (command "break" p1 p1)
 (command "break" p2 p2)

(DEFUN C:B1 ()
 (PROMPT "\nBreak Point")
 (TERPRI)
 (setq obj nil)
 (while (null obj)
   (setq obj (entsel "\nSelect object to break: "))
 )
 (redraw (car obj) 3)
 (initget 1)
 (setq point (getpoint "\nBreak point : "))
 (COMMAND "_.BREAK" obj "_F" point point)
 (PRINC)
)

;;;=====================[ BreakObject.lsp ]=============================
;;; Author: Copyright© 2006-2012 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org    
;;;   http://www.theswamp.org/index.php?topic=10370.0
;;; Version:  2.2  July 28, 2012
;;;=====================================================================
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED     ;
;;;   WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR  ;
;;;   PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.            ;
;;;                                                                    ;
;;;  You are hereby granted permission to use, copy and modify this    ;
;;;  software without charge, provided you do so exclusively for       ;
;;;  your own use or for use by others in your organization in the     ;
;;;  performance of their normal duties, and provided further that     ;
;;;  the above copyright notice appears in all copies and both that    ;
;;;  copyright notice and the limited warranty and restricted rights   ;
;;;  notice below appear in all supporting documentation.              ;
;;;=====================================================================
(defun gn ( l n / f )
 (defun f ( a b )
   (if (and a (< 0 b))
     (cons (car a) (f (setq l (cdr a)) (1- b)))
   )
 )
 (if l (cons (f l n) (gn l n)))
)
(defun getcltouching (sscros pt / ss lst lstb lstc objl intpt intpts)
 (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"))))
   )
   (ssdel (ssname sscros 0) ss)
   (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
                     (setq intpt (vl-catch-all-apply
                       '(lambda ()
                          (vlax-safearray->list
                            (vlax-variant-value
                              (vla-intersectwith y x acextendnone)
                            )))))))
               (progn
                 (setq intpts (gn intpt 3))
                 (foreach ipt intpts
                   (setq lstc (cons (cons (vlax-vla-object->ename x) (list ipt)) lstc))
                 )
               )
             )
           ) objl)
      ) lst)
 )
 (setq lstc (vl-sort lstc '(lambda (a b) (< (distance pt (cadr a)) (distance pt (cadr b))))))
 (setq intpts (list (cadar lstc) (cadadr lstc)))
 intpts
)
(defun c:B2 (/ cmd ss1 ss2 pt touch) (vl-load-com)
 
 (command "_.undo" "_begin")
 (setq cmd (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (setq ss1 (ssadd))
 (if (and (not (prompt "\nSelect object to break with touching & press enter: "))
          (setq ss2 (ssget "_+.:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
          (setq pt (cadr(cadddr(car (ssnamex ss2 0)))))
          (setq touch (getcltouching ss2 pt))
     )
     (progn
       (command "_.break" pt "F" (car touch) (car touch))
       (command "_.break" pt "F" (cadr touch) (cadr touch))
     )
 )
 (setvar "CMDECHO" cmd)
 (command "_.undo" "_end")
 (princ)
)
(prompt "\nEnter B2 to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;;    E n d   O f   F i l e   I f   y o u   A r e   H e r e       
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.

(defun C:BKI (/ ln pt1) ;;break at intersection
(setq osm (getvar 'osmode)) 
(setq cmd1 (getvar 'cmdecho))
(setvar 'cmdecho 0) 
(setvar 'osmode 32) 
(setq ln (entsel "\nChoose Line to Break...")) 
(setq pt1 (getpoint "\nPick Break Point.. ")) 
(command "break" ln "f" pt1 "@") 
(setvar 'osmode osm) 
(setvar 'cmdecho cmd1) 
(princ) 
)

;;;=====================[ BreakObject.lsp ]=============================
;;; Author: Copyright© 2006-2012 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org    
;;;   http://www.theswamp.org/index.php?topic=10370.0
;;; Version:  2.2  July 28, 2012
;;;=====================================================================
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED     ;
;;;   WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR  ;
;;;   PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.            ;
;;;                                                                    ;
;;;  You are hereby granted permission to use, copy and modify this    ;
;;;  software without charge, provided you do so exclusively for       ;
;;;  your own use or for use by others in your organization in the     ;
;;;  performance of their normal duties, and provided further that     ;
;;;  the above copyright notice appears in all copies and both that    ;
;;;  copyright notice and the limited warranty and restricted rights   ;
;;;  notice below appear in all supporting documentation.              ;
;;;=====================================================================
(defun prelst ( l i / n r )
 (while (and (setq n (car l)) (not (equal n i 1e-))
   (setq r (cons n r) l (cdr l))
 )
 (reverse r)
)
(defun sufflst ( l i / n r c )
 (setq l (reverse l) c (length l))
 (while (and (setq n (car l)) (not (equal n i 1e-))
   (setq r (cons n r) l (cdr l))
 )
 (if (/= (length r) c) r)
)
(defun gn ( l n / f )
 (defun f ( a b )
   (if (and a (< 0 b))
     (cons (car a) (f (setq l (cdr a)) (1- b)))
   )
 )
 (if l (cons (f l n) (gn l n)))
)
(defun getcltouching (sscros pt / ss lst lstb lstc objl intpt intpt1 intpt2 intpts)
 (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"))))
   )
   (ssdel (ssname sscros 0) ss)
   (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
                     (setq intpt (vl-catch-all-apply
                       '(lambda ()
                          (vlax-safearray->list
                            (vlax-variant-value
                              (vla-intersectwith y x acextendnone)
                            )))))))
               (progn
                 (setq intpts (gn intpt 3))
                 (foreach ipt intpts
                   (setq lstc (cons (cons (vlax-curve-getparamatpoint y ipt) (list ipt)) lstc))
                 )
               )
             )
           ) objl)
      ) lst)
 )
 (setq lstc (cons (cons (vlax-curve-getparamatpoint (car objl) (setq pt (vlax-curve-getclosestpointto (car objl) pt))) (list pt)) lstc))
 (setq lstc (vl-sort lstc '(lambda (a b) (< (car a) (car b)))))
 (setq lstc (mapcar 'cadr lstc))
 (setq intpt1 (last (prelst lstc pt)))
 (setq intpt2 (car (sufflst lstc pt)))
 (setq intpts (list intpt1 intpt2))
 intpts
)
(defun c:B2 (/ cmd ss1 ss2 pt touch) (vl-load-com)
 
 (command "_.undo" "_begin")
 (setq cmd (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (setq ss1 (ssadd))
 (if (and (not (prompt "\nSelect object to break with touching"))
          (setq ss2 (ssget "_+.:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
          (setq pt (cadr(cadddr(car (ssnamex ss2 0)))))
          (setq pt (vlax-curve-getclosestpointto (ssname ss2 0) pt))
          (setq touch (getcltouching ss2 pt))
     )
     (progn
       (command "_.break" (car (nentselp pt)) (car touch) (car touch))
       (command "_.break" (car (nentselp pt)) (cadr touch) (cadr touch))
     )
 )
 (setvar "CMDECHO" cmd)
 (command "_.undo" "_end")
 (princ)
)
(prompt "\nEnter B2 to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;;    E n d   O f   F i l e   I f   y o u   A r e   H e r e       
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.