Single touch and break the intersection line/polyline

[nalsur8]

Hi,

 

 

Single touch and break the intersection line/polyline

 

i try create with this one, but it's seem like not corret

 

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

[MSasu]

Not sure that I fully understand your sketch, but I believe that you can solve that very easy using the built-in command TRIM. Just press at the first prompter (cutting edges selection) and next select the part you want to remove.

[nalsur8]

hi,

 

i don't want to delete or remove the picked line, i just want break the point, so later i can change the remain line to hidden or change color, if use trim command the picked line will gone

[Alejandros85]

Hi nalsur8, try this code:

 

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

 

And sorry for my english, i am from Costa Rica.

 

regards

[marko_ribar]

Here, I've modified CAB's code... See if this can help you...

 

;;;=====================[ BreakObject.lsp ]=============================
;;; Author: Copyright© 2006-2012 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org    
;;;   http://www.theswamp.org/index.php?topic=10370.0
;;; Version:  2.2  July 28, 2012
;;;=====================================================================
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED     ;
;;;   WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR  ;
;;;   PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.            ;
;;;                                                                    ;
;;;  You are hereby granted permission to use, copy and modify this    ;
;;;  software without charge, provided you do so exclusively for       ;
;;;  your own use or for use by others in your organization in the     ;
;;;  performance of their normal duties, and provided further that     ;
;;;  the above copyright notice appears in all copies and both that    ;
;;;  copyright notice and the limited warranty and restricted rights   ;
;;;  notice below appear in all supporting documentation.              ;
;;;=====================================================================

(defun gn ( l n / f )
 (defun f ( a b )
   (if (and a (< 0 b))
     (cons (car a) (f (setq l (cdr a)) (1- b)))
   )
 )
 (if l (cons (f l n) (gn l n)))
)

(defun getcltouching (sscros pt / ss lst lstb lstc objl intpt intpts)
 (and
   (setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
         objl (mapcar 'vlax-ename->vla-object lstb)
   )
   (setq
     ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
                          (cons 410 (getvar "ctab"))))
   )
   (ssdel (ssname sscros 0) ss)
   (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (setq lst (mapcar 'vlax-ename->vla-object lst))
   (mapcar
     '(lambda (x)
        (mapcar
          '(lambda (y)
             (if (not
                   (vl-catch-all-error-p
                     (setq intpt (vl-catch-all-apply
                       '(lambda ()
                          (vlax-safearray->list
                            (vlax-variant-value
                              (vla-intersectwith y x acextendnone)
                            )))))))
               (progn
                 (setq intpts (gn intpt 3))
                 (foreach ipt intpts
                   (setq lstc (cons (cons (vlax-vla-object->ename x) (list ipt)) lstc))
                 )
               )
             )
           ) objl)
      ) lst)
 )
 (setq lstc (vl-sort lstc '(lambda (a b) (< (distance pt (cadr a)) (distance pt (cadr b))))))
 (setq intpts (list (cadar lstc) (cadadr lstc)))
 intpts
)

(defun c:B2 (/ cmd ss1 ss2 pt touch) (vl-load-com)
 
 (command "_.undo" "_begin")
 (setq cmd (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (setq ss1 (ssadd))

 (if (and (not (prompt "\nSelect object to break with touching & press enter: "))
          (setq ss2 (ssget "_+.:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
          (setq pt (cadr(cadddr(car (ssnamex ss2 0)))))
          (setq touch (getcltouching ss2 pt))
     )
     (progn
       (command "_.break" pt "F" (car touch) (car touch))
       (command "_.break" pt "F" (cadr touch) (cadr touch))
     )
 )
 (setvar "CMDECHO" cmd)
 (command "_.undo" "_end")
 (princ)
)

(prompt "\nEnter B2 to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;;    E n d   O f   F i l e   I f   y o u   A r e   H e r e       
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.

M.R.

B2.LSP

Edited October 16, 2012 by marko_ribar

[marko_ribar]

Sorry for my late update; code changed - I think that now it suits your needs...

 

M.R.

[nalsur8]

Alenjandros85,

 

Thank for your code, it's usefull too.. but it's not what i mean

 

marko_ribar,

 

Thank the code it's what i mean and thank again to modify the code

for me

[Dadgad]

It seems like your problem has already been solved,

but your question reminded me of a good tip from Lynn Allen

about speeding up your break command. One which i have implemented and which I like very much.

This will enable you to create a single break point, the location of which is specified

by the location of your first click, done.

 

Thanks Lynn!

[nod684]

try this : it will enable you to select a line and ask you for breaking point. Osnap is automatically set at intersection

 

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

[marko_ribar]

My apology, one more revision :

 

;;;=====================[ BreakObject.lsp ]=============================
;;; Author: Copyright© 2006-2012 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org    
;;;   http://www.theswamp.org/index.php?topic=10370.0
;;; Version:  2.2  July 28, 2012
;;;=====================================================================
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED     ;
;;;   WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR  ;
;;;   PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.            ;
;;;                                                                    ;
;;;  You are hereby granted permission to use, copy and modify this    ;
;;;  software without charge, provided you do so exclusively for       ;
;;;  your own use or for use by others in your organization in the     ;
;;;  performance of their normal duties, and provided further that     ;
;;;  the above copyright notice appears in all copies and both that    ;
;;;  copyright notice and the limited warranty and restricted rights   ;
;;;  notice below appear in all supporting documentation.              ;
;;;=====================================================================

(defun prelst ( l i / n r )
 (while (and (setq n (car l)) (not (equal n i 1e-))
   (setq r (cons n r) l (cdr l))
 )
 (reverse r)
)

(defun sufflst ( l i / n r c )
 (setq l (reverse l) c (length l))
 (while (and (setq n (car l)) (not (equal n i 1e-))
   (setq r (cons n r) l (cdr l))
 )
 (if (/= (length r) c) r)
)

(defun gn ( l n / f )
 (defun f ( a b )
   (if (and a (< 0 b))
     (cons (car a) (f (setq l (cdr a)) (1- b)))
   )
 )
 (if l (cons (f l n) (gn l n)))
)

(defun getcltouching (sscros pt / ss lst lstb lstc objl intpt intpt1 intpt2 intpts)
 (and
   (setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
         objl (mapcar 'vlax-ename->vla-object lstb)
   )
   (setq
     ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
                          (cons 410 (getvar "ctab"))))
   )
   (ssdel (ssname sscros 0) ss)
   (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (setq lst (mapcar 'vlax-ename->vla-object lst))
   (mapcar
     '(lambda (x)
        (mapcar
          '(lambda (y)
             (if (not
                   (vl-catch-all-error-p
                     (setq intpt (vl-catch-all-apply
                       '(lambda ()
                          (vlax-safearray->list
                            (vlax-variant-value
                              (vla-intersectwith y x acextendnone)
                            )))))))
               (progn
                 (setq intpts (gn intpt 3))
                 (foreach ipt intpts
                   (setq lstc (cons (cons (vlax-curve-getparamatpoint y ipt) (list ipt)) lstc))
                 )
               )
             )
           ) objl)
      ) lst)
 )
 (setq lstc (cons (cons (vlax-curve-getparamatpoint (car objl) (setq pt (vlax-curve-getclosestpointto (car objl) pt))) (list pt)) lstc))
 (setq lstc (vl-sort lstc '(lambda (a b) (< (car a) (car b)))))
 (setq lstc (mapcar 'cadr lstc))
 (setq intpt1 (last (prelst lstc pt)))
 (setq intpt2 (car (sufflst lstc pt)))
 (setq intpts (list intpt1 intpt2))
 intpts
)

(defun c:B2 (/ cmd ss1 ss2 pt touch) (vl-load-com)
 
 (command "_.undo" "_begin")
 (setq cmd (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (setq ss1 (ssadd))

 (if (and (not (prompt "\nSelect object to break with touching"))
          (setq ss2 (ssget "_+.:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
          (setq pt (cadr(cadddr(car (ssnamex ss2 0)))))
          (setq pt (vlax-curve-getclosestpointto (ssname ss2 0) pt))
          (setq touch (getcltouching ss2 pt))
     )
     (progn
       (command "_.break" (car (nentselp pt)) (car touch) (car touch))
       (command "_.break" (car (nentselp pt)) (cadr touch) (cadr touch))
     )
 )
 (setvar "CMDECHO" cmd)
 (command "_.undo" "_end")
 (princ)
)

(prompt "\nEnter B2 to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;;    E n d   O f   F i l e   I f   y o u   A r e   H e r e       
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.

M.R.

B2.LSP

Edited October 18, 2012 by marko_ribar
code changed to work also in older versions A2008, A2009

[marko_ribar]

Only recently I've noticed that code didn't work properly in older versions of AutoCAD - now tested on A2008, A2009...

 

So B2.lsp is again updated to be used and on older versions of AutoCAD...

 

Sincerely, regards M.R.

[nalsur8]

Marko Ribar, TQ

 

tested with acad2002 with no problem,

i just add code for *error* trap when user press ESC