break all at intersection

 

;;; Some of the following code are writen by QJCHEN
;;; South China University of Technology
;;; Purpose: To Break all the entities at intersection
;;; Version: 0.1
;;; Limitation: For self intersect object,need run twice
;;; 2006.05.27
;;; Thanks to the Great code from Charles Alan Butler & Will DeLoach at
;;; Theswamp.org
;;; and the Korea friend from [url]http://xoutside.com/[/url]
;;; Modified By Andrea Andreetti for All language compaptibilities May 26 2006
(defun startTimer () 
 (setq time (getvar "DATE")) 
) 
(defun endTimer (func) 
 (setq time    (- (getvar "DATE") time) 
       seconds (* 86400.0 (- time (fix time))) 
 ) 
 (gc) 
 (outPut seconds func) 
) 
(defun outPut (secs def) 
 (princ "\nPurging...") 
 (command "PURGE" "Layers" "*" "N") 
 (gc) 
 (princ (strcat "\nTimed " def ": " (rtos secs 2 6))) 
 (princ) 
) 



(defun c:brkall(/ a b i p selset j ent)
  (command "_undo" "_be")
  (startTimer)
  (setting)
  (prompt "\nSelect objects to break: ")
  (setq a (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
  (setq b (findallintersction a))
  (setq i 0)
  (repeat (length b)
    (setq p (nth i b))
    (setq selset (selectatonepoint p))
    (setq j 0)
    (repeat (sslength selset)
      (setq ent (ssname selset j))
      (newbreak ent p)               ; (command "._break" ent p "@")
      (setq j (1+ j))
    )
    (setq i (1+ i))
  )
  (resetting)
  (endTimer (vl-symbol-name 'c:brkall)) 
  (command "_undo" "_e")
  (princ)
)
;;; by Q.J.CHEN
;;; Purpose: To Select entities at one point
;;; The "tor" control the minimum distance between two point
(defun selectatonepoint (a / tor p1 p2 ss)
  (setq tor 0.01)
  (setq p1 (polar a (* (/ 135 180) pi) tor))
  (setq p2 (polar a (* (/ 315 180) pi) tor))
  (setq ss (ssget "_c" p1 p2))           ; (command "erase" ss "")
  ss
)
;;; by Q.J.CHEN
;;; Purpose: To Find all intersection in one ssget set
(defun findallintersction (sset / interlst ssl i e1 j e2 l)
  (setq interlst nil)
  (setq ssl (sslength sset)
    i 0
  )
  (repeat ssl
    (setq e1 (ssname sset i))
    (setq j (1+ i))
    (repeat (- ssl (1+ i))
      (setq e2 (ssname sset j))
      (setq l (kht-intersect e1 e2))
      (setq interlst (append
               interlst
               l
             )
      )
      (setq j (1+ j))
    )
    (setq i (1+ i))
  )
  interlst
)
;;; The following code are taken from xoutside.com
;;; http://xoutside.com/CAD/lisp/lisp_chair.htm
;;; Thanks to the Korea friend
;;; Purpose: Get the intersection of Two object
(defun kht-intersect (en1 en2 / a b x ex ex-app c d e)
  (vl-load-com)
  (setq c (cdr (assoc 0 (entget en1)))
    d (cdr (assoc 0 (entget en2)))
  )
  (if (or
    (= c "TEXT")
    (= d "TEXT")
      )
    (setq e -1)
  )
  (setq En1 (vlax-ename->vla-object En1))
  (setq En2 (vlax-ename->vla-object En2))
  (setq a (vla-intersectwith en1 en2 acExtendNone))
  (setq a (vlax-variant-value a))
  (setq b (vlax-safearray-get-u-bound a 1))
  (if (= e -1)
    (setq b e)
  )
  (if (/= b -1)
    (progn
      (setq a (vlax-safearray->list a))
      (repeat (/ (length a) 3)
    (setq ex-app (append
               ex-app
               (list (list (car a) (cadr a) (caddr a)))
             )
    )
    (setq a (cdr (cdr (cdr a))))
      )
      ex-app
    )
    nil
  )
)
(defun kht:list->safearray (lst datatype)
  (vlax-safearray-fill (vlax-make-safearray (eval datatype) (cons 0
                                  (1-
                                      (length lst)
                                  )
                                )
               ) lst
  )
)
;;; The following code are writen by Charles Alan Butler & Will DeLoach
;;; who come from Theswamp.org
;;; =======================[ BreakAtObject.lsp ]=======================
;;; Author: Charles Alan Butler & Will DeLoach
;;; Version:  1.5 Feb. 22, 2006
;;; Purpose: Break lines, plines, splines, ellipse, circles & arcs
;;;          with a crossing object or user line, not blocks
;;; Sub_Routines: ssget->vla-list
;;;               list->3pair
;;; Requirements:
;;; Returns:
;;; ==============================================================
;;;  Ignores objects on locked layers
;;;  This code is still under deveopment
(defun newbreak (ent pt / obj2Break p1param p2param p2)
  (setq obj2Break (vlax-ename->vla-object ent))
  (cond
    ((and
       (= "AcDbSpline" (vla-get-objectname obj2Break)) ; only closed
                       ; splines
       (vlax-curve-isClosed obj2Break)
     )
      (setq p1param (vlax-curve-getparamatpoint obj2Break pt)
        p2param (+ p1param 0.000001)
        p2 (vlax-curve-getPointAtParam obj2Break p2param)
      )
      (command "._break" (vlax-vla-object->ename obj2Break) "_non"
           (trans pt 0 1) "non" (trans p2 0 1)
      )
    )
    ((= "AcDbCircle" (vla-get-objectname obj2Break)) ; break the circle
      (setq p1param (vlax-curve-getparamatpoint obj2Break pt)
        p2param (+ p1param 0.000001)
        p2 (vlax-curve-getPointAtParam obj2Break p2param)
      )
      (command "._break" (vlax-vla-object->ename obj2Break) "_non"
           (trans pt 0 1) "_non" (trans p2 0 1)
      )
      (setq en (entlast))
    )
    ((and
       (= "AcDbEllipse" (vla-get-objectname obj2Break))    ; only closed
                       ; ellipse
       (vlax-curve-isClosed obj2Break)
     )                       ;  Break the ellipse, code borrowed
                       ; from Joe Burke  6/6/2005
      (setq p1param (vlax-curve-getparamatpoint obj2Break pt)
        p2param (+ p1param 0.000001) ; (vlax-curve-getparamatpoint obj
                       ; p2)
        minparam (min
               p1param
               p2param
             )
        maxparam (max
               p1param
               p2param
             )
      )
      (vlax-put obj2Break 'startparameter maxparam)
      (vlax-put obj2Break 'endparameter (+ minparam (* pi 2)))
    )                       ; ==================================
                       ;   Objects that can be broken
                       ; ==================================
    (t
      (command "._break" ent pt "@")
    )
  )
)
;;; The following code taken from Mr.Tony Hotchkiss at Cadalyst
(defun err (s)
  (if (= s "Function cancelled")
    (princ "\nALIGNIT - cancelled: ")
    (progn
      (princ "\nALIGNIT - Error: ")
      (princ s)
      (terpri)
    )                       ; _ end of progn
  )                       ; _ end of if
  (resetting)
  (princ "SYSTEM VARIABLES have been reset\n")
  (princ)
)
;;; err
;;; setting and resetting the system variables
(defun setv (systvar newval / x)
  (setq x (read (strcat systvar "1")))
  (set x (getvar systvar))
  (setvar systvar newval)
)
;;; setv
(defun setting ()
  (setq oerr *error*)
  (setq *error* err)
  (setv "BLIPMODE" 0)
  (setv "CMDECHO" 0)
  (setv "OSMODE" 0)
)
;;; setting
(defun rsetv (systvar)
  (setq x (read (strcat systvar "1")))
  (setvar systvar (eval x))
)
;;; rsetv
(defun resetting ()
  (rsetv "BLIPMODE")
  (rsetv "CMDECHO")
  (rsetv "OSMODE")
  (setq *error* oerr)
)
;;; -------------------------------------------------------