【练习题】选线打断自身以及选线打断其他线

yjr111 · 发表于 2011-11-23 11:56:22

本帖最后由 yjr111 于 2011-11-25 00:02 编辑

虽然论坛已经有很多帖子，但抛开帖子，发现纯粹自己写一个打断其实并不简单，发此贴，望高手能提供好思路。。。

（间距默认为0，即普通单点打断,命令brs）

;;;;;;;;;;;;;;;;;;与线相交交点打断;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;BY YJR111 2011-11-20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;适用于所有曲线，但多段线打断不充分;;;;;;;;;;;;;;;;;
(defun c:br (/ n e ee s
lst_e vla_x vla_y point vla_point
p_lst point1 dxf10_line dxf11_line
ee_new ee_last ss sss
)
(command "_.undo" "be" )
(setq oldosmode (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setvar "orthomode" 0)
(setq n 0)
(setq ee_last (entlast))
(setq sss (ssadd))
(setq ee (car (entsel "\n选择一条曲线：")))
(setq vla_ee (vlax-ename->vla-object ee))
(vla-getboundingbox vla_ee 'min 'max)
(setq minpoint (vlax-safearray->list min)
maxpoint (vlax-safearray->list max)
)
;(command "line" minpoint maxpoint "")
;(redraw (entlast) 3)
(INITGET 128 "S O")
(SETQ KEY
(GETKWORD
"\n 凡与所选曲线相交的曲线被打断(S)或所选曲线自身在交点被打断[O]"
) ;_ 结束GETKWORD
) ;_ 结束SETQ
(if (not KEY)
(setq key "S")
) ;_ 结束if
(setq ss (ssget "c" maxpoint minpoint)
n 0
) ;_ 结束setq
(while (< n (sslength ss))
(setq e (ssname ss n)
s (entget e)
lst_e (append lst_e (list e))
n (1+ n)
) ;_ 结束setq
;_ 结束setq
) ;_ 结束while
(setq n 0
i 0
) ;_ 结束setq
(foreach y lst_e
(setq vla_y (vlax-ename->vla-object y))
(if (and (not (equal vla_ee vla_y))
(/= (safearray-value
(vlax-variant-value
(setq vla_point (vlax-invoke-method
vla_ee
'IntersectWith
vla_y
acExtendNone
) ;_ 结束vlax-invoke-method
) ;_ 结束setq
) ;_ 结束vlax-variant-value
) ;_ 结束safearray-value
nil
) ;_ 结束/=
) ;_ 结束and
(progn
(setq
point (vlax-safearray->list (vlax-variant-value vla_point))
) ;_ 结束setq
(if (> (length point) 3)
(progn
(setq point1 (list (nth 3 point) (nth 4 point) (last point))
p_lst (cons point1 p_lst)
) ;_ 结束setq
(setq point (list (car point) (cadr point) (caddr point))
p_lst (cons point p_lst)
) ;_ 结束setq
(if (= key "S")
(progn
(command "_.break" y point1 "@")
(command "_.break" y point "@")
) ;_ 结束progn
;_ 结束progn
) ;_ 结束if
) ;_ 结束setq
(progn
(setq point (vlax-safearray->list
(vlax-variant-value vla_point)
) ;_ 结束vlax-safearray->list
) ;_ 结束vlax-safearray->list
(if (not (or (equal (vlax-curve-getstartpoint vla_y) point 1e-4)
(equal (vlax-curve-getendpoint vla_y)point 1e-4)
)
) ;_ 结束not
(setq p_lst (cons point p_lst))
) ;_ 结束setq
(if (= key "S")
(command "_.break" y point "@")
) ;_ 结束if
) ;_ 结束progn
) ;_ 结束if
) ;_ 结束progn
) ;_ 结束if
) ;_ 结束foreach
(if (= key "O")
(progn
(foreach x p_lst
(setq i 0)
(if (> (sslength sss) 0)
(while (< i (sslength sss))
(setq ee (ssname sss i))
(command "_.break" ee x "@")
(setq i (1+ i))
) ;_ 结束while
) ;_ 结束if
(command "_.break" ee x "@")
(ssdel ee ss )
(setq sss (ssget "c" minpoint maxpoint))
(setq n 0)
(repeat (sslength ss)
(setq i 0)
(while (< i (sslength sss))
(if (equal (ssname ss n) (ssname sss i))
(progn
(ssdel (ssname sss i) sss)
(setq i (sslength sss))
) ;_ 结束progn
) ;_ 结束if
(setq i (1+ i))
) ;_ 结束while
(setq n (1+ n))
) ;_ 结束repeat
(command "_.select" SS SSS "")
(setq ss (ssget "P"))
)
) ;_ 结束progn
) ;_ 结束if
(princ (strcat "共打断<" (itoa (length p_lst)) " >个交点!"))
(setvar "osmode" oldosmode)
(command "_.undo" "end" )
(princ)
) ;_ 结束defun

;;;;;;;;;;;;;;;;;;与线相交交点打断;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;BY YJR111 2011-11-20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;适用于所有曲线，但多段线打断不充分;;;;;;;;;;;;;;;;; 
(defun c:br (/         n   e     ee       s 
       lst_e     vla_x   vla_y     point     vla_point 
       p_lst     point1   dxf10_line       dxf11_line 
       ee_new    ee_last  ss  sss 
      ) 
  (command "_.undo" "be" ) 
  (setq oldosmode (getvar "osmode")) 
  (setvar "osmode" 0) 
  (setvar "cmdecho" 0) 
  (setvar "orthomode" 0) 
  (setq n 0) 
  (setq ee_last (entlast)) 
  (setq sss (ssadd)) 
  (setq ee (car (entsel "\n选择一条曲线："))) 
  (setq vla_ee (vlax-ename->vla-object ee)) 
  (vla-getboundingbox vla_ee 'min 'max) 
  (setq minpoint (vlax-safearray->list min) 
  maxpoint (vlax-safearray->list max) 
  ) 
  ;(command "line" minpoint maxpoint "") 
  ;(redraw (entlast) 3) 
  (INITGET 128 "S O") 
  (SETQ  KEY 
   (GETKWORD 
     "\n 凡与所选曲线相交的曲线被打断(S)或所选曲线自身在交点被打断[O]" 
   ) ;_ 结束GETKWORD 
  ) ;_ 结束SETQ 
  (if (not KEY) 
    (setq key "S") 
  ) ;_ 结束if 
  (setq  ss (ssget "c"  maxpoint minpoint) 
  n  0 
  ) ;_ 结束setq 
   
  (while (< n (sslength ss)) 
    (setq e  (ssname ss n) 
    s  (entget e) 
    lst_e  (append lst_e (list e)) 
    n  (1+ n) 
    ) ;_ 结束setq 
;_ 结束setq 
  ) ;_ 结束while 
  (setq  n 0 
  i 0 
  ) ;_ 结束setq 
  (foreach y lst_e 
    (setq vla_y (vlax-ename->vla-object y)) 
    
    (if  (and (not (equal vla_ee vla_y)) 
       (/= (safearray-value 
       (vlax-variant-value 
         (setq vla_point (vlax-invoke-method 
               vla_ee 
               'IntersectWith 
               vla_y 
               acExtendNone 
             ) ;_ 结束vlax-invoke-method 
         ) ;_ 结束setq 
       ) ;_ 结束vlax-variant-value 
     ) ;_ 结束safearray-value 
     nil 
       ) ;_ 结束/= 
  ) ;_ 结束and 
      (progn 
  (setq 
    point  (vlax-safearray->list (vlax-variant-value vla_point)) 
  ) ;_ 结束setq 
  (if (> (length point) 3) 
    (progn 
      (setq point1 (list (nth 3 point) (nth 4 point) (last point)) 
      p_lst   (cons point1 p_lst) 
      ) ;_ 结束setq 
      (setq point  (list (car point) (cadr point) (caddr point)) 
      p_lst  (cons point p_lst) 
      ) ;_ 结束setq 
      (if  (= key "S") 
        (progn 
    (command "_.break" y point1 "@") 
    (command "_.break" y point "@") 
        ) ;_ 结束progn 
;_ 结束progn 
      ) ;_ 结束if 
    ) ;_ 结束setq 
 
    (progn 
      (setq point  (vlax-safearray->list 
        (vlax-variant-value vla_point) 
      ) ;_ 结束vlax-safearray->list 
      ) ;_ 结束vlax-safearray->list 
      
      (if  (not (or (equal (vlax-curve-getstartpoint vla_y) point 1e-4) 
                         (equal (vlax-curve-getendpoint vla_y)point 1e-4) 
                     ) 
                ) ;_ 结束not 
            (setq p_lst (cons point p_lst)) 
      ) ;_ 结束setq 
      (if  (= key "S") 
        (command "_.break" y point "@") 
      ) ;_ 结束if 
    ) ;_ 结束progn 
  ) ;_ 结束if 
      ) ;_ 结束progn 
    ) ;_ 结束if 
  ) ;_ 结束foreach 
            (if  (= key "O") 
        (progn 
        (foreach x p_lst 
         (setq i 0) 
    (if (> (sslength sss) 0) 
 
      (while (
        (setq ee (ssname sss i)) 
       (command "_.break" ee x "@") 
        (setq i (1+ i)) 
      ) ;_ 结束while 
    ) ;_ 结束if 
    (command "_.break" ee x "@") 
          (ssdel ee  ss ) 
 
    (setq sss  (ssget "c" minpoint maxpoint)) 
                
    (setq n 0) 
    (repeat  (sslength ss) 
      (setq i 0) 
      (while (
        (if  (equal (ssname ss n) (ssname sss i)) 
          (progn 
      (ssdel (ssname sss i) sss) 
      (setq i (sslength sss)) 
          ) ;_ 结束progn 
        ) ;_ 结束if 
        (setq i (1+ i)) 
 
      ) ;_ 结束while 
      (setq n (1+ n)) 
    ) ;_ 结束repeat 
          
    (command "_.select" SS SSS "") 
    (setq ss (ssget "P")) 
                ) 
 
        ) ;_ 结束progn 
      ) ;_ 结束if 
  (princ (strcat "共打断<" (itoa (length p_lst)) " >个交点!")) 
  (setvar "osmode" oldosmode) 
  (command "_.undo" "end" ) 
  (princ) 
) ;_ 结束defun

aggdqty · 发表于 2023-5-9 20:29:53

你好。麻烦问一下，如何设置打断距离

qfkxc · 发表于 2011-11-23 12:17:52

多谢楼主分享源码

maiko · 发表于 2011-11-23 12:24:53

多谢楼主分享

xotoo · 发表于 2011-11-23 12:38:39

2012 x64运行不能正确打断

cjrun · 发表于 2011-11-23 19:09:23

求得交点重画线段应该会简单点吧！

cjrun · 发表于 2011-11-23 19:39:31

本帖最后由 cjrun 于 2011-11-23 20:52 编辑

cjrun 发表于 2011-11-23 19:09
求得交点重画线段应该会简单点吧！

你是对的，很多曲线不能重画！

xotoo · 发表于 2011-11-23 20:37:35

又测试了一下
自身打断不能实现

我很需要这样一个程序
楼主重新完善一下吧

yjr111 · 发表于 2011-11-24 23:55:51

本帖最后由 yjr111 于 2011-11-25 00:04 编辑

打断竟然比想象中难好多，要怎么样才能打断充分呢？经过2天苦思冥想，多次测试，也许下面的程序能给你个答案！（请勿踢我

）

程序一楼更新。。。。。。

x_s_s_1 · 发表于 2011-11-25 08:08:58

本帖最后由 x_s_s_1 于 2011-11-25 08:11 编辑

lee mac的圆打断，希望对您有启发

;;--------------------=={ Circle Break }==--------------------;;
;; ;;
;; Breaks a circle into two arcs and places the arc created ;;
;; from the portion of the circle selected on designated ;;
;; layer. ;;
;;------------------------------------------------------------;;
;;------------------------------------------------------------;;
(defun c:cbrk
( / *error* _StartUndo _EndUndo LM:Permute LM:Clockwise-p LM:RemovePairs
acdoc c cn el hiddenlayer norm p1 p2 ra xang
)
;;------------------------------------------------------------;;
(setq HiddenLayer "1") ;; Name of Hidden Layer
;;------------------------------------------------------------;;
(defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)
(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(defun LM:Permute ( a b / c )
(setq c (eval a)) (set a (eval b)) (set b c)
)
(defun LM:Clockwise-p ( p1 p2 p3 )
( (lambda ( n ) (< (car (trans p2 0 n)) (car (trans p1 0 n)))) (mapcar '- p1 p3))
)
(defun LM:RemovePairs ( lst pairs )
(vl-remove-if '(lambda ( pair ) (member (car pair) pairs)) lst)
)
;;------------------------------------------------------------;;
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(or (tblsearch "LAYER" HiddenLayer)
(vla-add (vla-get-layers acdoc) HiddenLayer)
)
(if
(and
(setq c
(LM:Selectif "\nSelect Circle: "
'(lambda ( x ) (eq "CIRCLE" (cdr (assoc 0 (entget (car x)))))) entsel nil
)
)
(setq p1 (getpoint "\nSelect First Break Point: "))
(progn
(while (equal p1 (setq p2 (getpoint "\nSelect Second Break Point: ")) 1e-6)
(princ "\n** Points must be distinct **")
)
p2
)
)
(progn
(_StartUndo acdoc)
(setq norm (trans '(0. 0. 1.) 1 0 t)
xAng (angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 norm t)))
(setq p1 (trans (vlax-curve-getClosestPointto (car c) (trans p1 1 0)) 0 norm)
p2 (trans (vlax-curve-getClosestPointto (car c) (trans p2 1 0)) 0 norm)
cn (cdr (assoc 10 (setq el (entget (car c)))))
ra (cdr (assoc 40 el))
)
(if (< (- (angle cn p1) xAng) (- (angle cn p2) xAng))
(LM:Permute 'p1 'p2)
)
(
(lambda ( a1 a2 )
(mapcar
(function
(lambda ( la s e )
(entmake
(append (list (cons 0 "ARC") (cons 8 la) (cons 50 s) (cons 51 e))
(LM:RemovePairs el '(0 5 8 100))
)
)
)
)
(if (LM:Clockwise-p p1 (trans (cadr c) 1 norm) p2)
(list (cdr (assoc 8 el)) HiddenLayer)
(list HiddenLayer (cdr (assoc 8 el)))
)
(list a1 a2)
(list a2 a1)
)
)
(angle cn p1) (angle cn p2)
)
(entdel (car c))
(_EndUndo acdoc)
)
)
(princ)
)
;;---------------------=={ Select if }==----------------------;;
;; ;;
;; Provides continuous selection prompts until either a ;;
;; predicate function is validated or a keyword is supplied. ;;
;;------------------------------------------------------------;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; msg - prompt string ;;
;; pred - optional predicate function [selection list arg] ;;
;; func - selection function to invoke ;;
;; keyw - optional initget argument list ;;
;;------------------------------------------------------------;;
;; Returns: Entity selection list, keyword, or nil ;;
;;------------------------------------------------------------;;
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))
(while
(progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try again.")
)
( (eq 'STR (type sel))
nil
)
( (vl-consp sel)
(if (and pred (not (pred sel)))
(princ "\nInvalid Object Selected.")
)
)
)
)
)
sel
)
(vl-load-com) (princ)
;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;;

;;--------------------=={ Circle Break }==--------------------;; 
;;                                                            ;; 
;;  Breaks a circle into two arcs and places the arc created  ;; 
;;  from the portion of the circle selected on designated     ;; 
;;  layer.                                                    ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;; 
;;------------------------------------------------------------;; 
 
(defun c:cbrk 
 
  ( / *error* _StartUndo _EndUndo LM:Permute LM:Clockwise-p LM:RemovePairs 
      acdoc c cn el hiddenlayer norm p1 p2 ra xang 
  ) 
 
;;------------------------------------------------------------;; 
 
  (setq HiddenLayer "1") ;; Name of Hidden Layer 
 
;;------------------------------------------------------------;; 
 
  (defun *error* ( msg ) 
    (if acdoc (_EndUndo acdoc)) 
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") 
        (princ (strcat "\n** Error: " msg " **"))) 
    (princ) 
  ) 
 
  (defun _StartUndo ( doc ) (_EndUndo doc) 
    (vla-StartUndoMark doc) 
  ) 
 
  (defun _EndUndo ( doc ) 
    (if (= 8 (logand 8 (getvar 'UNDOCTL))) 
      (vla-EndUndoMark doc) 
    ) 
  ) 
 
  (defun LM:Permute ( a b / c ) 
    (setq c (eval a)) (set a (eval b)) (set b c) 
  ) 
 
  (defun LM:Clockwise-p ( p1 p2 p3 ) 
    ( (lambda ( n ) (< (car (trans p2 0 n)) (car (trans p1 0 n)))) (mapcar '- p1 p3)) 
  ) 
 
  (defun LM:RemovePairs ( lst pairs ) 
    (vl-remove-if '(lambda ( pair ) (member (car pair) pairs)) lst) 
  ) 
 
;;------------------------------------------------------------;; 
 
  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))) 
   
  (or (tblsearch "LAYER" HiddenLayer) 
      (vla-add (vla-get-layers acdoc) HiddenLayer) 
  ) 
 
  (if 
    (and 
      (setq c 
        (LM:Selectif "\nSelect Circle: " 
         '(lambda ( x ) (eq "CIRCLE" (cdr (assoc 0 (entget (car x)))))) entsel nil 
        ) 
      ) 
      (setq p1 (getpoint "\nSelect First Break Point: ")) 
      (progn 
        (while (equal p1 (setq p2 (getpoint "\nSelect Second Break Point: ")) 1e-6) 
          (princ "\n** Points must be distinct **") 
        ) 
        p2 
      ) 
    ) 
    (progn 
      (_StartUndo acdoc) 
       
      (setq norm (trans '(0. 0. 1.) 1 0 t) 
            xAng (angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 norm t))) 
       
      (setq p1 (trans (vlax-curve-getClosestPointto (car c) (trans p1 1 0)) 0 norm) 
            p2 (trans (vlax-curve-getClosestPointto (car c) (trans p2 1 0)) 0 norm) 
            cn (cdr (assoc 10 (setq el (entget (car c))))) 
            ra (cdr (assoc 40 el)) 
      ) 
      (if (< (- (angle cn p1) xAng) (- (angle cn p2) xAng)) 
        (LM:Permute 'p1 'p2) 
      ) 
      ( 
        (lambda ( a1 a2 ) 
          (mapcar 
            (function 
              (lambda ( la s e ) 
                (entmake 
                  (append (list (cons 0 "ARC") (cons 8 la) (cons 50 s) (cons 51 e)) 
                    (LM:RemovePairs el '(0 5 8 100)) 
                  ) 
                ) 
              ) 
            ) 
            (if (LM:Clockwise-p p1 (trans (cadr c) 1 norm) p2) 
              (list (cdr (assoc 8 el)) HiddenLayer) 
              (list HiddenLayer (cdr (assoc 8 el))) 
            ) 
            (list a1 a2) 
            (list a2 a1) 
          ) 
        ) 
        (angle cn p1) (angle cn p2) 
      ) 
      (entdel (car c)) 
 
      (_EndUndo acdoc) 
    ) 
  ) 
  (princ) 
) 
 
;;---------------------=={ Select if }==----------------------;; 
;;                                                            ;; 
;;  Provides continuous selection prompts until either a      ;; 
;;  predicate function is validated or a keyword is supplied. ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  msg  - prompt string                                      ;; 
;;  pred - optional predicate function [selection list arg]   ;; 
;;  func - selection function to invoke                       ;; 
;;  keyw - optional initget argument list                     ;; 
;;------------------------------------------------------------;; 
;;  Returns:  Entity selection list, keyword, or nil          ;; 
;;------------------------------------------------------------;; 
 
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))   
  (while 
    (progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg)) 
      (cond 
        ( (= 7 (getvar 'ERRNO)) 
          (princ "\nMissed, Try again.") 
        ) 
        ( (eq 'STR (type sel)) 
          nil 
        ) 
        ( (vl-consp sel) 
          (if (and pred (not (pred sel))) 
            (princ "\nInvalid Object Selected.") 
          ) 
        ) 
      ) 
    ) 
  ) 
  sel 
) 
 
(vl-load-com) (princ) 
 
;;------------------------------------------------------------;; 
;;                         End of File                        ;; 
;;------------------------------------------------------------;;

x_s_s_1 · 发表于 2011-11-25 08:36:06

本帖最后由 x_s_s_1 于 2011-11-25 08:52 编辑

不知为何不能直接回复您的帖子，还有图片贴不出来，很佩服您的学习精神，可惜我没有多余时间，搞结构都比较忙

，我一般是拿来主义，局部自己会改一些就行了，以后还请您多指教。搜到一个Charles Alan Butler 的程序，希望也对您有启发。
达到您的效果可用BreakObject命令
有对话框的

;;;=======================[ BreakObjects.lsp ]==============================
;;; Contact @ www.TheSwamp.org
;;; Version: 2.1 Nov. 20,2008
;;; Purpose: Break All selected objects
;;; permitted objects are lines, lwplines, plines, splines,
;;; ellipse, circles & arcs
;;;
;;; Function c:MyBreak - DCL for selecting the routines
;;; Function c:BreakAll - Break all objects selected with each other
;;; Function c:BreakwObject - Break many objects with a single object
;;; Function c:BreakObject - Break a single object with other objects
;;; Function c:BreakWith - Break selected objects with other selected objects
;;; Function c:BreakTouching - Break objects touching selected objects
;;; Function c:BreakSelected - Break selected objects with any objects that touch it
;;; Revision 1.8 Added Option for Break Gap greater than zero
;;; NEW r1.9 c:BreakWlayer - Break objects with objects on a layer
;;; NEW r1.9 c:BreakWithTouching - Break touching objects with selected objects
;;; Revision 2.0 Fixed a bug when point to break is at the end of object
;;; Revision 2.1 Fixed another bug when point to break is at the end of object
;;;
;;;
;;; Function break_with - main break function called by all others and
;;; returns a list of new enames, see c:BreakAll
;;; for an example of using the return list
;;;
;;; Requirements: objects must have the same z-value
;;; Restrictions: Does not Break objects on locked layers
;;; Returns: none
;;;
;;;=====================================================================
;;; 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. ;
;;;=====================================================================
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
)
;; 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
;;
;; return list of enames of new objects
(vl-load-com)
(princ "\nCalculating Break Points, Please Wait.\n")
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; return T if entity is on a locked layer
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
;; return a list of objects from a selection set
;| (defun ssget->vla-list (ss)
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
)|;
(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)
;; return a list of lists grouped by 3 from a flat list
(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
;;========================================
;; New as per version 1.8 [BrkGap] --- This subroutine has been re-written
;; Loop through the break points breaking the entity
;; If the entity is not a closed entity then a new object is created
;; This object is added to a list. When break points don't fall on the current
;; entity the list of new entities are searched to locate the entity that the
;; point is on so it can be broken.
;; "Break with a Gap" has been added to this routine. The problem faced with
;; this method is that sections to be removed may lap if the break points are
;; too close to each other. The solution is to create a list of break point pairs
;; representing the gap to be removed and test to see if there i an overlap. If
;; there is then merge the break point pairs into one large gap. This way the
;; points will always fall on an object with one exception. If the gap is too near
;; the end of an object one break point will be off the end and therefore that
;; point will need to be replaced with the end point.
;; NOTE: in ACAD2000 the (vlax-curve-getdistatpoint function has proven unreliable
;; so I have used (vlax-curve-getdistatparam in most cases
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
brkptE brkpt result GapFlg result ignore dist tmppt
#ofpts 2gap enddist lastent obj2break stdist
)
(or BrkGap (setq BrkGap 0.0)) ; default to 0
(setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point
(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
GapFlg (not (zerop BrkGap)) ; gap > 0
closedobj (vlax-curve-isclosed obj2break)
)
;; when zero gap no need to break at end points
(if (zerop Brkgap)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)))
brkptlst)
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break x))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))
(if GapFlg ; gap > 0
;; Brkptlst starts as the break point and then a list of pairs of points
;; is creates as the break points
(progn
;; create a list of list of break points
;; ((idx# stpoint distance)(idx# endpoint distance)...)
(setq idx 0)
(foreach brkpt brkptlst
;; ----------------------------------------------------------
;; create start break point, then create end break point
;; ((idx# startpoint distance)(idx# endpoint distance)...)
;; ----------------------------------------------------------
(setq dist (cadr brkpt)) ; distance to center of gap
;; subtract gap to get start point of break gap
(cond
((and (minusp (setq stDist (- dist BrkGap))) closedobj )
(setq stdist (+ (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)) stDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((minusp stDist) ; off start of object so get startpoint
(setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; add gap to get end point of break gap
(cond
((and (> (setq stDist (+ dist BrkGap))
(setq endDist (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)))) closedobj )
(setq stdist (- stDist endDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((> stDist endDist) ; off end of object so get endpoint
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getendparam obj2break))
endDist) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; -------------------------------------------------------
(setq idx (1+ IDX))
) ; foreach brkpt brkptlst
(setq dlst (reverse dlst))
;; remove the points of the gap segments that overlap
(setq idx -1
2gap (* BrkGap 2)
#ofPts (length Brkptlst)
)
(while (<= (setq idx (1+ idx)) #ofPts)
(cond
((null result) ; 1st time through
(setq result (list (car dlst)) ; get first start point
result (cons (nth (1+(* idx 2)) dlst) result))
)
((= idx #ofPts) ; last pass, check for wrap
(if (and closedobj (> #ofPts 1)
(<= (+(- (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break))
(cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
(progn
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (cadr (reverse result)) result) ; get last end point
result (cdr (reverse result))
result (reverse (cdr result)))
)
)
)
;; Break Gap Overlaps
((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
)
;; Break Gap does Not Overlap previous point
(t
(setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
)
) ; end cond stmt
) ; while
;; setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...)
;; one of the pair of points will be on the object that
;; needs to be broken
(setq dlst (reverse result)
brkptlst nil)
(while dlst ; grab the points only
(setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
dlst (cddr dlst))
)
)
)
;; -----------------------------------------------------
;; (if (equal a ent) (princ)) ; debug CAB -------------
(foreach brkpt (reverse brkptlst)
(if GapFlg ; gap > 0
(setq brkptS (car brkpt)
brkptE (cadr brkpt))
(setq brkptS (car brkpt)
brkptE brkptS)
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj2break tmppt))))
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while (and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj tmppt)))
(null (setq obj2break obj)) ; switch objects, null causes exit
t
)
)
)
)
)
)
)
;| ;; ver 2.0 fix - removed this code as there are cases where the break point
;; is at the end of a line which is not a valid break but does no harm
(if (and brkobjlst idx (minusp idx)
(null (alert (strcat "Error - point not on object"
"\nPlease report this error to"
"\n CAB at TheSwamp.org"))))
(exit)
)
|;
;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB -------------
;; Handle any objects that can not be used with the Break Command
;; using one point, gap of 0.000001 is used
(setq closedobj (vlax-curve-isclosed obj2break))
(if GapFlg ; gap > 0
(if closedobj
(progn ; need to break a closed object
(setq brkpt2 (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
(command "._break" obj2break "_non" (trans brkpt2 0 1)
"_non" (trans brkptE 0 1))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(setq BrkptE brkpt2)
)
)
;; single breakpoint ----------------------------------------------------
;|(if (and closedobj ; problems with ACAD200 & this code
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001))))
)
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001)))
)|;
(if (and closedobj
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
)
) ; endif
;; (if (null brkptE) (princ)) ; debug
(setq LastEnt (GetLastEnt))
(command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast))))
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
) ; endif brkptlst
) ; defun break_obj
;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;===================================
;; CAB - return a list of new enames
(defun GetNewEntities (ename / new)
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (setq new (cons ename new)))
)
)
((alert "Ename wrong type."))
)
new
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(setq LastEntInDatabase (GetLastEnt))
(if (and ss2brk ss2brkwith)
(progn
(setq oc 0
ss2brkwithList (ssget->vla-list ss2brkwith))
(if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
(setq *BrkVerbose* t)
)
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
;; 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 ss2brkwithList
(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
)
(and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
)
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
)
)
)
)
(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
;; masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk) Gap)
)
)
)
)
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D O F M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;======================
;; Redraw ss with mode
;;======================
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(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
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D M A I N F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;===============================================
;; Break all objects selected with each other
;;===============================================
(defun c:BreakAll (/ cmd ss NewEnts AllEnts tmp)
(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;===========================================
;; Break a single object with other objects
;;===========================================
(defun c:BreakObject (/ cmd ss1 ss2 tmp)
(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; 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 Bgap) ; 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:BreakWobject (/ cmd ss1 ss2 tmp)
(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; 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 Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;==========================================
;; Break objects with objects on a layer
;;==========================================
;; New 08/01/2008
(defun c:BreakWlayer (/ cmd ss1 ss2 tmp lay)
(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\n*** Select single object for break layer: ***")
(if (and (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq lay (assoc 8 (entget (ssname ss2 0))))
(setq ss2 (ssget "_X" (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
lay (cons 410 (getvar "ctab")))))
(not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss1 (ssget (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 8 (strcat "~" (cdr lay))))))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;======================================================
;; Break selected objects with other selected objects
;;======================================================
(defun c:BreakWith (/ cmd ss1 ss2 tmp)
(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(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 Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=============================================
;; Break objects touching selected objects
;;=============================================
(defun c:BreakTouching (/ cmd ss1 ss2 tmp)
(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if (and (not (prompt "\nSelect object(s) to break & 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 Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=================================================
;; Break touching objects with selected objects
;;=================================================
;; New 08/01/2008
(defun c:BreakWithTouching (/ cmd ss1 ss2 tmp)
(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(prompt "\nSelect object(s) to break with & press enter: ")
(if (and (setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq tlst (gettouching ss2))
)
(progn
(setq tlst (vl-remove-if '(lambda (x)(ssmemb x ss2)) tlst)) ; remove if in picked ss
(mapcar '(lambda (x) (ssadd x ss1)) tlst) ; convert to a selection set
(break_with ss1 ss2 nil Bgap) ; ss1break 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 tmp)
(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & 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 Bgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;; ***************************************************
;; Function to create a dcl support file if it
;; does not exist
;; Usage : (create_dcl "file name")
;; Returns : T if successful else nil
;; ***************************************************
(defun create_Breakdcl (fname / acadfn dcl-rev-check)
;;=======================================
;; check revision date Routine
;;=======================================
(defun dcl-rev-check (fn / rvdate ln lp)
;; revision flag must match exactly and must
;; begin with //
(setq rvflag "// Revision Control 05/12/2008@14:11" )
(if (setq fn (findfile fn))
(progn ; check rev date
(setq lp 5) ; read 4 lines
(setq fn (open fn "r")) ; open file for reading
(while (> (setq lp (1- lp)) 0)
(setq ln (read-line fn)) ; get a line from file
(if (vl-string-search rvflag ln)
(setq lp 0)
)
)
(close fn) ; close the open file handle
(if (= lp -1)
nil ; no new dcl needed
t ; flag to create new file
)
)
t ; flag to create new file
)
)
(if (null(wcmatch (strcase fname) "*`.DCL"))
(setq fname (strcat fname ".DCL"))
)
(if (dcl-rev-check fname)
;; create dcl file in same directory as ACAD.PAT
(progn
(setq acadfn (findfile "ACAD.PAT")
fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname)
fn (open fn "w")
)
(foreach x (list
"// WARNING file will be recreated if you change the next line"
rvflag
"//BreakAll.DCL"
"BreakDCL : dialog { label = "[ Break All or Some by CAB v1.8 ]";"
" : text { label = "--=< Select type of Break Function needed >=--"; "
" key = "tm"; alignment = centered; fixed_width = true;}"
" spacer_1;"
" : button { key = "b1"; mnemonic = "T"; alignment = centered;"
" label = "Break all objects selected with each other";} "
" : button { key = "b2"; mnemonic = "T"; alignment = centered;"
" label = "Break selected objects with other selected objects";}"
" : button { key = "b3"; mnemonic = "T"; alignment = centered;"
" label = " Break selected objects with any objects that touch it";}"
" spacer_1;"
" : row { spacer_0;"
" : edit_box {key = "gap" ; width = 8; mnemonic = "G"; label = "Gap"; fixed_width = true;}"
" : button { label = "Help"; key = "help"; mnemonic = "H"; fixed_width = true;} "
" cancel_button;"
" spacer_0;"
" }"
"}"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\nDCL file created, please restart the routine"
"\n again if an error occures."))
t ; return True, file created
)
t ; return True, file found
)
) ; end defun
;;==============================
;; BreakAll Dialog Routine
;;==============================
(defun c:MyBreak(/ dclfile dcl# RunDCL BreakHelp cmd txt2num)
;; return number or nil
(defun txt2num (txt / num)
(if txt
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
)
(if (numberp num)
num
)
)
(defun mydonedialog (flag)
(setq DCLgap (txt2num (get_tile "gap")))
(done_dialog flag)
)
(defun RunDCL (/ action)
(or DCLgap (setq DCLgap 0)) ; error trap value
(action_tile "b1" "(mydonedialog 1)")
(action_tile "b2" "(mydonedialog 2)")
(action_tile "b3" "(mydonedialog 3)")
(action_tile "gap" "(setq DCLgap (txt2num value$))")
(set_tile "gap" (rtos DCLgap))
(action_tile "help" "(BreakHelp)")
(action_tile "cancel" "(done_dialog 0)")
(setq action (start_dialog))
(or DCLgap (setq DCLgap 0)) ; error trap value
(setq DCLgap (max DCLgap 0)) ; nu negative numbers
(cond
((= action 1) ; BreakAll
(command "_.undo" "_begin")
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil DCLgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(command "_.undo" "_end")
(princ)
)
((= action 2) ; BreakWith
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(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 DCLgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
)
((= action 3) ; BreakSelected
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & 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 DCLgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)
)
)
)
(defun BreakHelp ()
(alert
(strcat
"BreakAll.lsp (c) 2007-2008 Charles Alan Butler\n\n"
"This LISP routine will break objects based on the routine you select.\n"
"It will not break objects on locked layers and objects must have the same z-value.\n"
"Object types are limited to LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE\n"
"BreakAll - Break all objects selected with each other\n"
"BreakwObject - Break many objects with a single object\n"
"BreakObject - Break a single object with many objects \n"
"BreakWith - Break selected objects with other selected objects\n"
"BreakTouching - Break objects touching selected objects\n"
"BreakSelected - Break selected objects with any objects that touch it\n"
" The Gap distance is the total opening created.\n"
"You may run each routine by entering the function name at the command line.\n"
"For updates & comments contact Charles Alan Butler AKA CAB at TheSwamp.org.\n")
)
)
;;================================================================
;; Start of Routine
;;================================================================
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq dclfile "BreakAll.dcl")
(cond
((not (create_Breakdcl dclfile))
(prompt (strcat "\nCannot create " dclfile "."))
)
((< (setq dcl# (load_dialog dclfile)) 0)
(prompt (strcat "\nCannot load " dclfile "."))
)
((not (new_dialog "BreakDCL" dcl#))
(prompt (strcat "\nProblem with " dclfile "."))
)
((RunDCL)) ; No DCL problems: fire it up
)
(and cmd (setvar "CMDECHO" cmd))
(princ)
)
(prompt "Break routines loaded, Enter Mybreak to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;; E n d O f F i l e I f y o u A r e H e r e
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.

;;;=======================[ BreakObjects.lsp ]============================== 
;;; Author: Copyright?2006-2008 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org 
;;; Version:  2.1  Nov. 20,2008 
;;; Purpose: Break All selected objects 
;;;    permitted objects are lines, lwplines, plines, splines, 
;;;    ellipse, circles & arcs 
;;;                            
;;;  Function  c:MyBreak -       DCL for selecting the routines 
;;;  Function  c:BreakAll -      Break all objects selected with each other 
;;;  Function  c:BreakwObject  - Break many objects with a single object 
;;;  Function  c:BreakObject -   Break a single object with other objects 
;;;  Function  c:BreakWith -     Break selected objects with other selected objects 
;;;  Function  c:BreakTouching - Break objects touching selected objects 
;;;  Function  c:BreakSelected - Break selected objects with any objects that touch it 
;;;  Revision 1.8 Added Option for Break Gap greater than zero 
;;;  NEW r1.9  c:BreakWlayer -   Break objects with objects on a layer 
;;;  NEW r1.9  c:BreakWithTouching - Break touching objects with selected objects 
;;;  Revision 2.0 Fixed a bug when point to break is at the end of object 
;;;  Revision 2.1 Fixed another bug when point to break is at the end of object 
;;; 
;;; 
;;;  Function  break_with  - main break function called by all others and 
;;;                          returns a list of new enames, see c:BreakAll 
;;;                          for an example of using the return list 
;;; 
;;; Requirements: objects must have the same z-value 
;;; Restrictions: Does not Break objects on locked layers 
;;; Returns:  none 
;;; 
;;;===================================================================== 
;;;   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.              ; 
;;;===================================================================== 
 
 
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
;;               M A I N   S U B R O U T I N E                   
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
 
(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs 
                   onlockedlayer ssget->vla-list list->3pair GetNewEntities oc 
                   get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList 
                  ) 
  ;; 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 
  ;; 
  ;; return list of enames of new objects 
   
  (vl-load-com) 
   
  (princ "\nCalculating Break Points, Please Wait.\n") 
 
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
;;                S U B   F U N C T I O N S                      
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
 
  ;;  return T if entity is on a locked layer 
  (defun onlockedlayer (ename / entlst) 
    (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename))))) 
    (= 4 (logand 4 (cdr (assoc 70 entlst)))) 
  ) 
 
  ;;  return a list of objects from a selection set 
;|  (defun ssget->vla-list (ss) 
    (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss )))) 
  )|; 
  (defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7 
       (setq i -1) 
       (while (setq  ename (ssname ss (setq i (1+ i)))) 
         (setq allobj (cons (vlax-ename->vla-object ename) allobj)) 
       ) 
       allobj 
  ) 
   
  ;;  return a list of lists grouped by 3 from a flat list 
  (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   
;;======================================== 
;;   New as per version 1.8 [BrkGap] --- This subroutine has been re-written 
;;  Loop through the break points breaking the entity 
;;  If the entity is not a closed entity then a new object is created 
;;  This object is added to a list. When break points don't fall on the current 
;;  entity the list of new entities are searched to locate the entity that the 
;;  point is on so it can be broken. 
;;  "Break with a Gap" has been added to this routine. The problem faced with 
;;  this method is that sections to be removed may lap if the break points are 
;;  too close to each other. The solution is to create a list of break point pairs 
;;  representing the gap to be removed and test to see if there i an overlap. If 
;;  there is then merge the break point pairs into one large gap. This way the 
;;  points will always fall on an object with one exception. If the gap is too near 
;;  the end of an object one break point will be off the end and therefore that 
;;  point will need to be replaced with the end point. 
;;    NOTE: in ACAD2000 the (vlax-curve-getdistatpoint function has proven unreliable 
;;  so I have used (vlax-curve-getdistatparam in most cases 
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj 
                  minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS 
                  brkptE brkpt result GapFlg result ignore dist tmppt 
                  #ofpts 2gap enddist lastent obj2break stdist 
                 ) 
  (or BrkGap (setq BrkGap 0.0)) ; default to 0 
  (setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point 
   
  (setq obj2break ent 
        brkobjlst (list ent) 
        enttype   (cdr (assoc 0 (entget ent))) 
        GapFlg    (not (zerop BrkGap)) ; gap > 0 
        closedobj (vlax-curve-isclosed obj2break) 
  ) 
  ;; when zero gap no need to break at end points 
  (if (zerop Brkgap) 
    (setq spt (vlax-curve-getstartpoint ent) 
          ept (vlax-curve-getendpoint ent) 
          brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001) 
                                                 (< (distance x ept) 0.0001))) 
                                 brkptlst) 
    ) 
  ) 
  (if brkptlst 
    (progn 
  ;;  sort break points based on the distance along the break object 
  ;;  get distance to break point, catch error if pt is off end 
  ;; ver 2.0 fix - added COND to fix break point is at the end of a 
  ;; line which is not a valid break but does no harm 
  (setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break 
                                               ;; ver 2.0 fix 
                                               (cond ((vlax-curve-getparamatpoint obj2break x)) 
                                                   ((vlax-curve-getparamatpoint obj2break 
                                                     (vlax-curve-getclosestpointto obj2break x)))))) 
                            ) brkptlst)) 
  ;; sort primary list on distance 
  (setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2))))) 
   
  (if GapFlg ; gap > 0 
    ;; Brkptlst starts as the break point and then a list of pairs of points 
    ;;  is creates as the break points 
    (progn 
      ;;  create a list of list of break points 
      ;;  ((idx# stpoint distance)(idx# endpoint distance)...) 
      (setq idx 0) 
      (foreach brkpt brkptlst 
         
        ;; ---------------------------------------------------------- 
        ;;  create start break point, then create end break point    
        ;;  ((idx# startpoint distance)(idx# endpoint distance)...)   
        ;; ---------------------------------------------------------- 
        (setq dist (cadr brkpt)) ; distance to center of gap 
        ;;  subtract gap to get start point of break gap 
        (cond 
          ((and (minusp (setq stDist (- dist BrkGap))) closedobj ) 
           (setq stdist (+ (vlax-curve-getdistatparam obj2break 
                             (vlax-curve-getendparam obj2break)) stDist)) 
           (setq dlst (cons (list idx 
                                  (vlax-curve-getpointatparam obj2break 
                                         (vlax-curve-getparamatdist obj2break stDist)) 
                                  stDist) dlst)) 
           ) 
          ((minusp stDist) ; off start of object so get startpoint 
           (setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst)) 
           ) 
          (t 
           (setq dlst (cons (list idx 
                                  (vlax-curve-getpointatparam obj2break 
                                         (vlax-curve-getparamatdist obj2break stDist)) 
                                  stDist) dlst)) 
          ) 
        ) 
        ;;  add gap to get end point of break gap 
        (cond 
          ((and (> (setq stDist (+ dist BrkGap)) 
                   (setq endDist (vlax-curve-getdistatparam obj2break 
                                     (vlax-curve-getendparam obj2break)))) closedobj ) 
           (setq stdist (- stDist endDist)) 
           (setq dlst (cons (list idx 
                                  (vlax-curve-getpointatparam obj2break 
                                         (vlax-curve-getparamatdist obj2break stDist)) 
                                  stDist) dlst)) 
           ) 
          ((> stDist endDist) ; off end of object so get endpoint 
           (setq dlst (cons (list idx 
                                  (vlax-curve-getpointatparam obj2break 
                                        (vlax-curve-getendparam obj2break)) 
                                  endDist) dlst)) 
           ) 
          (t 
           (setq dlst (cons (list idx 
                                  (vlax-curve-getpointatparam obj2break 
                                         (vlax-curve-getparamatdist obj2break stDist)) 
                                  stDist) dlst)) 
          ) 
        ) 
        ;; ------------------------------------------------------- 
        (setq idx (1+ IDX)) 
      ) ; foreach brkpt brkptlst 
       
 
      (setq dlst (reverse dlst)) 
      ;;  remove the points of the gap segments that overlap 
      (setq idx -1 
            2gap (* BrkGap 2) 
            #ofPts (length Brkptlst) 
      ) 
      (while (<= (setq idx (1+ idx)) #ofPts) 
        (cond 
          ((null result) ; 1st time through 
           (setq result (list (car dlst)) ; get first start point 
                 result (cons (nth (1+(* idx 2)) dlst) result)) 
          ) 
          ((= idx #ofPts) ; last pass, check for wrap 
           (if (and closedobj (> #ofPts 1) 
                    (<= (+(- (vlax-curve-getdistatparam obj2break 
                            (vlax-curve-getendparam obj2break)) 
                          (cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap)) 
             (progn 
               (if (zerop (rem (length result) 2)) 
                 (setq result (cdr result)) ; remove the last end point 
               ) 
               ;;  ignore previous endpoint and present start point 
               (setq result (cons (cadr (reverse result)) result) ; get last end point 
                     result (cdr (reverse result)) 
                     result (reverse (cdr result))) 
             ) 
           ) 
          ) 
          ;; Break Gap Overlaps 
          ((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap)) 
           (if (zerop (rem (length result) 2)) 
             (setq result (cdr result)) ; remove the last end point 
           ) 
           ;;  ignore previous endpoint and present start point 
           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point 
           ) 
          ;; Break Gap does Not Overlap previous point 
          (t 
           (setq result (cons (nth (* idx 2) dlst) result)) ; get this start point 
           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point 
          ) 
        ) ; end cond stmt 
      ) ; while 
       
      ;;  setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...) 
      ;;  one of the pair of points will be on the object that 
      ;;  needs to be broken 
      (setq dlst     (reverse result) 
            brkptlst nil) 
      (while dlst ; grab the points only 
        (setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst) 
              dlst   (cddr dlst)) 
      ) 
    ) 
  ) 
  ;;   ----------------------------------------------------- 
 
  ;; (if (equal  a ent) (princ)) ; debug CAB  ------------- 
 
  (foreach brkpt (reverse brkptlst) 
    (if GapFlg ; gap > 0 
      (setq brkptS (car brkpt) 
            brkptE (cadr brkpt)) 
      (setq brkptS (car brkpt) 
            brkptE brkptS) 
    ) 
    ;;  get last entity created via break in case multiple breaks 
    (if brkobjlst 
      (progn 
        (setq tmppt brkptS) ; use only one of the pair of breakpoints 
        ;;  if pt not on object x, switch objects 
        (if (not (numberp (vl-catch-all-apply 
                            'vlax-curve-getdistatpoint (list obj2break tmppt)))) 
          (progn ; find the one that pt is on 
            (setq idx (length brkobjlst)) 
            (while (and (not (minusp (setq idx (1- idx)))) 
                        (setq obj (nth idx brkobjlst)) 
                        (if (numberp (vl-catch-all-apply 
                                       'vlax-curve-getdistatpoint (list obj tmppt))) 
                          (null (setq obj2break obj)) ; switch objects, null causes exit 
                          t 
                        ) 
                   ) 
            ) 
          ) 
        ) 
      ) 
    ) 
    ;| ;; ver 2.0 fix - removed this code as there are cases where the break point 
       ;; is at the end of a line which is not a valid break but does no harm 
    (if (and brkobjlst idx (minusp idx) 
             (null (alert (strcat "Error - point not on object" 
                                  "\nPlease report this error to" 
                                  "\n   CAB at TheSwamp.org")))) 
      (exit) 
    ) 
    |; 
    ;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB  ------------- 
 
    ;;  Handle any objects that can not be used with the Break Command 
    ;;  using one point, gap of 0.000001 is used 
    (setq closedobj (vlax-curve-isclosed obj2break)) 
    (if GapFlg ; gap > 0 
      (if closedobj 
        (progn ; need to break a closed object 
          (setq brkpt2 (vlax-curve-getPointAtDist obj2break 
                     (- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001))) 
          (command "._break" obj2break "_non" (trans brkpt2 0 1) 
                   "_non" (trans brkptE 0 1)) 
          (and (= "CIRCLE" enttype) (setq enttype "ARC")) 
          (setq BrkptE brkpt2) 
        ) 
      ) 
      ;;  single breakpoint ---------------------------------------------------- 
      ;|(if (and closedobj ; problems with ACAD200 & this code 
               (not (setq brkptE (vlax-curve-getPointAtDist obj2break 
                       (+ (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001)))) 
          ) 
        (setq brkptE (vlax-curve-getPointAtDist obj2break 
                       (- (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001))) 
         
      )|; 
      (if (and closedobj 
               (not (setq brkptE (vlax-curve-getPointAtDist obj2break 
                       (+ (vlax-curve-getdistatparam obj2break 
                            ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))) 
                            ;; ver 2.0 fix 
                            (cond ((vlax-curve-getparamatpoint obj2break brkpts)) 
                                  ((vlax-curve-getparamatpoint obj2break 
                                      (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001))))) 
        (setq brkptE (vlax-curve-getPointAtDist obj2break 
                       (- (vlax-curve-getdistatparam obj2break 
                            ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))) 
                            ;; ver 2.0 fix 
                            (cond ((vlax-curve-getparamatpoint obj2break brkpts)) 
                                  ((vlax-curve-getparamatpoint obj2break 
                                      (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001))) 
       ) 
    ) ; endif 
    
    ;; (if (null brkptE) (princ)) ; debug 
    
    (setq LastEnt (GetLastEnt)) 
    (command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1)) 
    (and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r")) 
    (and (= "CIRCLE" enttype) (setq enttype "ARC")) 
    (if (and (not closedobj) ; new object was created 
             (not (equal LastEnt (entlast)))) 
        (setq brkobjlst (cons (entlast) brkobjlst)) 
    ) 
  ) 
  ) 
  ) ; endif brkptlst 
   
) ; defun break_obj 
 
;;==================================== 
;;  CAB - get last entity in datatbase 
(defun GetLastEnt ( / ename result ) 
  (if (setq result (entlast)) 
    (while (setq ename (entnext result)) 
      (setq result ename) 
    ) 
  ) 
  result 
) 
;;=================================== 
;;  CAB - return a list of new enames 
(defun GetNewEntities (ename / new) 
  (cond 
    ((null ename) (alert "Ename nil")) 
    ((eq 'ENAME (type ename)) 
      (while (setq ename (entnext ename)) 
        (if (entget ename) (setq new (cons ename new))) 
      ) 
    ) 
    ((alert "Ename wrong type.")) 
  ) 
  new 
) 
 
   
  ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
  ;;         S T A R T  S U B R O U T I N E   H E R E               
  ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
    
    (setq LastEntInDatabase (GetLastEnt)) 
    (if (and ss2brk ss2brkwith) 
    (progn 
      (setq oc 0 
            ss2brkwithList (ssget->vla-list ss2brkwith)) 
      (if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000) 
        (setq *BrkVerbose* t) 
      ) 
      (and *BrkVerbose* 
           (princ (strcat "Objects to be Checked: " 
            (itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n"))) 
      ;;  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  ss2brkwithList 
              (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 
              ) 
              (and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r"))) 
            ) 
            (if lst 
              (setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist)) 
            ) 
          ) 
        ) 
      ) 
 
       
      (and *BrkVerbose* (princ "\nBreaking Objects.\n")) 
      (setq *brkcnt* 0) ; break counter 
      ;;  masterlist = ((ent brkpts)(ent brkpts)...) 
      (if masterlist 
        (foreach obj2brk masterlist 
          (break_obj (car obj2brk) (cdr obj2brk) Gap) 
        ) 
      ) 
      ) 
  ) 
;;============================================================== 
   (and (zerop *brkcnt*) (princ "\nNone to be broken.")) 
   (setq *BrkVerbose* nil) 
  (GetNewEntities LastEntInDatabase) ; return list of enames of new objects 
) 
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
;;      E N D   O F    M A I N   S U B R O U T I N E             
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
 
 
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
;;           M A I N   S U B   F U N C T I O N S                  
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
 
  ;;====================== 
  ;;  Redraw ss with mode 
  ;;====================== 
  (defun ssredraw (ss mode / i num) 
    (setq i -1) 
    (while (setq ename (ssname ss (setq i (1+ i)))) 
      (redraw (ssname ss i) mode) 
    ) 
  ) 
 
  ;;=========================================================================== 
  ;;  get all objects touching entities in the sscross                         
  ;;  limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE" 
  ;;  returns a list of enames 
  ;;=========================================================================== 
  (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 
  ) 
 
 
 
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
;;          E N D   M A I N    F U N C T I O N S                  
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
 
 
 
;;=============================================== 
;;   Break all objects selected with each other   
;;=============================================== 
(defun c:BreakAll (/ cmd ss NewEnts AllEnts tmp) 
 
  (command "_.undo" "_begin") 
  (setq cmd (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (or Bgap (setq Bgap 0)) ; default 
  (initget 4) ; no negative numbers 
  (if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> "))) 
    (setq Bgap tmp) 
  ) 
  ;;  get objects to break 
  (prompt "\nSelect objects to break with each other & press enter: ") 
  (if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")))) 
     (setq NewEnts (Break_with ss ss nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self) 
           ; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) 
           ) 
  ) 
  (setvar "CMDECHO" cmd) 
  (command "_.undo" "_end") 
  (princ) 
) 
 
 
;;=========================================== 
;;  Break a single object with other objects 
;;=========================================== 
(defun c:BreakObject (/ cmd ss1 ss2 tmp) 
 
  (command "_.undo" "_begin") 
  (setq cmd (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (or Bgap (setq Bgap 0)) ; default 
  (initget 4) ; no negative numbers 
  (if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> "))) 
    (setq Bgap tmp) 
  ) 
 
  ;;  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 Bgap) ; 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:BreakWobject (/ cmd ss1 ss2 tmp) 
 
  (command "_.undo" "_begin") 
  (setq cmd (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (or Bgap (setq Bgap 0)) ; default 
  (initget 4) ; no negative numbers 
  (if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> "))) 
    (setq Bgap tmp) 
  ) 
  ;;  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 Bgap) ; ss1break ss2breakwith (flag nil = not to break with self) 
  ) 
 
  (setvar "CMDECHO" cmd) 
  (command "_.undo" "_end") 
  (princ) 
) 
 
 
;;========================================== 
;;  Break objects with objects on a layer    
;;========================================== 
;;  New 08/01/2008 
(defun c:BreakWlayer (/ cmd ss1 ss2 tmp lay) 
 
  (command "_.undo" "_begin") 
  (setq cmd (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (or Bgap (setq Bgap 0)) ; default 
  (initget 4) ; no negative numbers 
  (if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> "))) 
    (setq Bgap tmp) 
  ) 
  ;;  get objects to break 
  (prompt "\n***  Select single object for break layer:  ***") 
   
  (if (and (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")))) 
           (setq lay (assoc 8 (entget (ssname ss2 0)))) 
           (setq ss2 (ssget "_X" (list 
                                   '(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE") 
                                   lay (cons 410 (getvar "ctab"))))) 
           (not (prompt "\nSelect object(s) to break & press enter: ")) 
           (setq ss1 (ssget (list 
                              '(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE") 
                              (cons 8 (strcat "~" (cdr lay)))))) 
      ) 
    (break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self) 
  ) 
 
  (setvar "CMDECHO" cmd) 
  (command "_.undo" "_end") 
  (princ) 
) 
 
 
;;====================================================== 
;;  Break selected objects with other selected objects   
;;====================================================== 
(defun c:BreakWith (/ cmd ss1 ss2 tmp) 
 
  (command "_.undo" "_begin") 
  (setq cmd (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (or Bgap (setq Bgap 0)) ; default 
  (initget 4) ; no negative numbers 
  (if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> "))) 
    (setq Bgap tmp) 
  ) 
  ;;  get objects to break 
  (prompt "\nBreak selected objects with other selected objects.") 
  (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 Bgap) ; ss1break ss2breakwith (flag nil = not to break with self) 
  ) 
 
  (setvar "CMDECHO" cmd) 
  (command "_.undo" "_end") 
  (princ) 
) 
 
 
 
;;============================================= 
;;  Break objects touching selected objects    
;;============================================= 
 
(defun c:BreakTouching (/ cmd ss1 ss2 tmp) 
 
  (command "_.undo" "_begin") 
  (setq cmd (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (setq ss1 (ssadd)) 
  (or Bgap (setq Bgap 0)) ; default 
  (initget 4) ; no negative numbers 
  (if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> "))) 
    (setq Bgap tmp) 
  ) 
  ;;  get objects to break 
  (prompt "\nBreak objects touching selected objects.") 
  (if (and (not (prompt "\nSelect object(s) to break & 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 Bgap) ; ss1break ss2breakwith (flag nil = not to break with self) 
  ) 
 
  (setvar "CMDECHO" cmd) 
  (command "_.undo" "_end") 
  (princ) 
) 
 
 
 
;;================================================= 
;;  Break touching objects with selected objects    
;;================================================= 
;;  New 08/01/2008 
(defun c:BreakWithTouching (/ cmd ss1 ss2 tmp) 
 
  (command "_.undo" "_begin") 
  (setq cmd (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (setq ss1 (ssadd)) 
  (or Bgap (setq Bgap 0)) ; default 
  (initget 4) ; no negative numbers 
  (if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> "))) 
    (setq Bgap tmp) 
  ) 
 
  ;;  get objects to break 
  (prompt "\nBreak objects touching selected objects.") 
  (prompt "\nSelect object(s) to break with & press enter: ") 
  (if (and (setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")))) 
           (setq tlst (gettouching ss2)) 
      ) 
    (progn 
      (setq tlst (vl-remove-if '(lambda (x)(ssmemb x ss2)) tlst)) ;  remove if in picked ss 
      (mapcar '(lambda (x) (ssadd x ss1)) tlst) ; convert to a selection set 
      (break_with ss1 ss2 nil Bgap) ; ss1break 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 tmp) 
   
  (command "_.undo" "_begin") 
  (setq cmd (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (setq ss1 (ssadd)) 
  (or Bgap (setq Bgap 0)) ; default 
  (initget 4) ; no negative numbers 
  (if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> "))) 
    (setq Bgap tmp) 
  ) 
  ;;  get objects to break 
  (prompt "\nBreak selected objects with any objects that touch it.") 
  (if (and (not (prompt "\nSelect object(s) to break with touching & 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 Bgap) ; ss2break ss1breakwith (flag nil = not to break with self) 
  ) 
 
  (setvar "CMDECHO" cmd) 
  (command "_.undo" "_end") 
  (princ) 
) 
 
;; *************************************************** 
;;     Function to create a dcl support file if it    
;;       does not exist                               
;;     Usage : (create_dcl "file name")                
;;     Returns : T if successful else nil             
;; *************************************************** 
(defun create_Breakdcl (fname / acadfn dcl-rev-check) 
  ;;======================================= 
  ;;      check revision date Routine          
  ;;======================================= 
  (defun dcl-rev-check (fn / rvdate ln lp) 
    ;;  revision flag must match exactly and must 
    ;;  begin with // 
    (setq rvflag "//  Revision Control 05/12/2008@14:11" ) 
    (if (setq fn (findfile fn)) 
      (progn ; check rev date 
        (setq lp 5) ; read 4 lines 
        (setq fn (open fn "r")) ; open file for reading 
        (while (> (setq lp (1- lp)) 0) 
          (setq ln (read-line fn)) ; get a line from file 
          (if (vl-string-search rvflag ln) 
            (setq lp 0) 
          ) 
        ) 
        (close fn) ; close the open file handle 
        (if (= lp -1) 
          nil ; no new dcl needed 
          t ; flag to create new file 
        ) 
      ) 
      t ; flag to create new file 
    ) 
  ) 
  (if (null(wcmatch (strcase fname) "*`.DCL")) 
    (setq fname (strcat fname ".DCL")) 
  ) 
  (if (dcl-rev-check fname) 
    ;; create dcl file in same directory as ACAD.PAT   
    (progn 
      (setq acadfn (findfile "ACAD.PAT") 
            fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname) 
            fn (open fn "w") 
      ) 
      (foreach x (list 
                   "// WARNING file will be recreated if you change the next line" 
                   rvflag 
                   "//BreakAll.DCL" 
                   "BreakDCL : dialog { label = "[ Break All or Some by CAB  v1.8 ]";" 
                   "  : text { label = "--=<  Select type of Break Function needed  >=--"; " 
                   "           key = "tm"; alignment = centered; fixed_width = true;}" 
                   "    spacer_1;" 
                   "    : button { key = "b1"; mnemonic = "T";  alignment = centered;" 
                   "               label = "Break all objects selected with each other";} " 
                   "    : button { key = "b2"; mnemonic = "T"; alignment = centered;" 
                   "               label = "Break selected objects with other selected objects";}" 
                   "    : button { key = "b3"; mnemonic = "T";  alignment = centered;" 
                   "               label = " Break selected objects with any  objects that touch it";}" 
                   "    spacer_1;" 
                   "  : row { spacer_0;" 
                   "    : edit_box {key = "gap" ; width = 8; mnemonic = "G"; label = "Gap"; fixed_width = true;}" 
                   "    : button { label = "Help"; key = "help"; mnemonic = "H"; fixed_width = true;} " 
                   "    cancel_button;" 
                   "    spacer_0;" 
                   "  }" 
                   "}" 
                  ) ; endlist 
        (princ x fn) 
        (write-line "" fn) 
      ) ; end foreach 
      (close fn) 
      (setq acadfn nil) 
      (alert (strcat "\nDCL file created, please restart the routine" 
               "\n again if an error occures.")) 
      t ; return True, file created 
    ) 
    t ; return True, file found 
  ) 
) ; end defun 
 
 
;;============================== 
;;     BreakAll Dialog Routine   
;;============================== 
(defun c:MyBreak(/ dclfile dcl# RunDCL BreakHelp cmd txt2num) 
   ;;  return number or nil 
  (defun txt2num (txt / num) 
    (if txt 
    (or (setq num (distof txt 5)) 
        (setq num (distof txt 2)) 
        (setq num (distof txt 1)) 
        (setq num (distof txt 4)) 
        (setq num (distof txt 3)) 
    ) 
    ) 
    (if (numberp num) 
      num 
    ) 
  ) 
  (defun mydonedialog (flag) 
    (setq DCLgap (txt2num (get_tile "gap"))) 
    (done_dialog flag) 
  ) 
  (defun RunDCL (/ action) 
    (or DCLgap (setq DCLgap 0)) ; error trap value 
    (action_tile "b1" "(mydonedialog 1)") 
    (action_tile "b2" "(mydonedialog 2)") 
    (action_tile "b3" "(mydonedialog 3)") 
    (action_tile "gap" "(setq DCLgap (txt2num value$))") 
    (set_tile "gap" (rtos DCLgap)) 
    (action_tile "help" "(BreakHelp)") 
    (action_tile "cancel" "(done_dialog 0)") 
    (setq action (start_dialog)) 
    (or DCLgap (setq DCLgap 0)) ; error trap value 
    (setq DCLgap (max DCLgap 0)) ; nu negative numbers 
    
    (cond 
      ((= action 1) ; BreakAll 
         (command "_.undo" "_begin") 
  ;;  get objects to break 
  (prompt "\nSelect objects to break with each other & press enter: ") 
  (if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")))) 
     (setq NewEnts (Break_with ss ss nil DCLgap) ; ss2break ss2breakwith (flag nil = not to break with self) 
           ; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) 
           ) 
  ) 
  (command "_.undo" "_end") 
  (princ) 
       ) 
       
      ((= action 2) ; BreakWith 
         ;;  get objects to break 
  (prompt "\nBreak selected objects with other selected objects.") 
  (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 DCLgap) ; ss1break ss2breakwith (flag nil = not to break with self) 
  ) 
 
       ) 
      ((= action 3) ; BreakSelected 
  (setq ss1 (ssadd)) 
  ;;  get objects to break 
  (prompt "\nBreak selected objects with any objects that touch it.") 
  (if (and (not (prompt "\nSelect object(s) to break with touching & 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 DCLgap) ; ss2break ss1breakwith (flag nil = not to break with self) 
  ) 
       ) 
    ) 
  ) 
  (defun BreakHelp () 
    (alert 
      (strcat 
        "BreakAll.lsp               (c) 2007-2008 Charles Alan Butler\n\n" 
        "This LISP routine will break objects based on the routine you select.\n" 
        "It will not break objects on locked layers and objects must have the same z-value.\n" 
        "Object types are limited to LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE\n" 
        "BreakAll -      Break all objects selected with each other\n" 
        "BreakwObject  - Break many objects with a single object\n" 
        "BreakObject -   Break a single object with many objects \n" 
        "BreakWith -     Break selected objects with other selected objects\n" 
        "BreakTouching - Break objects touching selected objects\n" 
        "BreakSelected - Break selected objects with any objects that touch it\n" 
        " The Gap distance is the total opening created.\n" 
        "You may run each routine by entering the function name at the command line.\n" 
        "For updates & comments contact Charles Alan Butler AKA CAB at TheSwamp.org.\n") 
    ) 
  ) 
   
  ;;================================================================ 
  ;;                    Start of Routine                            
  ;;================================================================ 
  (vl-load-com) 
  (setq cmd (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (setq dclfile "BreakAll.dcl") 
  (cond 
    ((not (create_Breakdcl dclfile)) 
     (prompt (strcat "\nCannot create " dclfile ".")) 
    ) 
    ((< (setq dcl# (load_dialog dclfile)) 0) 
     (prompt (strcat "\nCannot load " dclfile ".")) 
    ) 
    ((not (new_dialog "BreakDCL" dcl#)) 
     (prompt (strcat "\nProblem with " dclfile ".")) 
    ) 
    ((RunDCL))      ; No DCL problems: fire it up 
  ) 
  (and cmd (setvar "CMDECHO" cmd)) 
  (princ) 
) 
(prompt "Break routines loaded, Enter Mybreak to run.") 
(princ) 
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\. 
;;    E n d   O f   F i l e   I f   y o u   A r e   H e r e       
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.

没对话框的

;;;=======================[ BreakObjects.lsp ]==============================
;;; Contact @ www.TheSwamp.org
;;; Version: 1.3 April 9,2007
;;; Globalization by XANADU - www.xanadu.cz
;;; Purpose: Break All selected objects
;;; permitted objects are lines, lwplines, plines, splines,
;;; ellipse, circles & arcs
;;;
;;; Function c:BreakAll - Break all objects selected
;;; Function c:BreakwObjects - Break many objects with a single object
;;; Function c:BreakObject - Break a single object with many objects
;;; Function c:BreakWith - Break selected objects with other selected objects
;;; Function c:BreakTouching - Break objects touching the single Break object
;;; Function c:BreakSelected - Break selected objects with any objects that touch it
;;;
;;; Sub_Routines:
;;; break_with
;;; ssget->vla-list
;;; list->3pair
;;; onlockedlayer
;;; get_interpts Return a list of intersect points
;;; break_obj Break entity at break points in list
;;; Requirements: objects must have the same z-value
;;; Restrictions: Does not Break objects on locked layers
;;; Returns: none
;;;=====================================================================
;;; 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. ;
;;;=====================================================================
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; 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))
)
)
)
)
;;==============================================================
)
(prompt "\nBreak Routines Loaded, Enter BreakAll, BreakEnt, or BreakWith to run.")
(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)
)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;; E n d O f F i l e I f y o u A r e H e r e
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.Charles Alan Butler

;;;=======================[ BreakObjects.lsp ]============================== 
;;; Author: Copyright?2006,2007 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org 
;;; Version:  1.3 April 9,2007 
;;; Globalization by XANADU - www.xanadu.cz 
;;; Purpose: Break All selected objects 
;;;    permitted objects are lines, lwplines, plines, splines, 
;;;    ellipse, circles & arcs 
;;;                            
;;;  Function  c:BreakAll -      Break all objects selected 
;;;  Function  c:BreakwObjects - Break many objects with a single object 
;;;  Function  c:BreakObject -   Break a single object with many objects 
;;;  Function  c:BreakWith -     Break selected objects with other selected objects 
;;;  Function  c:BreakTouching - Break objects touching the single Break object 
;;;  Function  c:BreakSelected - Break selected objects with any  objects that touch it 
;;;                     
;;; Sub_Routines:       
;;;    break_with       
;;;    ssget->vla-list 
;;;    list->3pair      
;;;    onlockedlayer    
;;;    get_interpts Return a list of intersect points 
;;;    break_obj  Break entity at break points in list 
;;; Requirements: objects must have the same z-value 
;;; Restrictions: Does not Break objects on locked layers 
;;; Returns:  none 
;;;===================================================================== 
;;;   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.              ; 
;;;===================================================================== 
 
 
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
;;               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)) 
        ) 
      ) 
      ) 
  ) 
;;============================================================== 
 
) 
(prompt "\nBreak Routines Loaded, Enter BreakAll, BreakEnt, or BreakWith to run.") 
(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) 
) 
 
 
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\. 
;;    E n d   O f   F i l e   I f   y o u   A r e   H e r e       
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.Charles Alan Butler

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

【练习题】选线打断自身以及选线打断其他线

本帖子中包含更多资源

点评

评分

相关帖子

点评

点评

评分