Topic: linehop lisp

[ronjonp]

Does anyone have routine that will trim one of the lines and make a hop when 2 intersecting lines are selected?

[hendie]

I know of one which will place an arc over the intersection if that's of any use to you

[ronjonp]

That would work. Would you post it?


Thanks,

Ron

[hendie]

erghh.. can't really ~ it's available as a download over at http://www.resourcecad.com

XCR ~ Vlisp routine which places an arc over the crossing intersection of lines or arcs. The user is prompted for the crossing line/arc, followed by the intersection. An arc is inserted in the crossing line/arc and the section of line/arc within the “crossing arc” is removed. The newly inserted “crossing arc” takes on the layer properties of the original line/arc selected. The diameter of the crossing arc is remembered through AutoCAD sessions by use of the config file and can be changed any time the routine is run.
Command line: XCR

if you don't want to use that one, I have code for another version I wrote some time ago but I'm leaving  tomorrow and won't be back for a week or so... sorry  

[CAB]

I seem to remember a thread about this some time back but can't find it.

Here is an old routine I created, but I think someone had a better one.

Code: [Select]

;;        Break Wire.lsp
;;      Created by C. Alan Butler  12/04/2003
;;         Ver 1.01  12/04/2003
;;  Routine to break crossing lines
;;  picked object must be a line
;;  Options to change break gap size
;;  Options to include Arc
;;  Enter bWire to run from the command line
;;  Pick a point on line to break or enter an option
;;  Press Enter to quit
;;
;;;
;;;   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.
;;;
;;
;;
;; error function & Routine Exit
(defun *error* (msg)
  (if
    (not
      (member
msg
'("console break" "Function cancelled" "quit / exit abort")
      )
    )
     (princ (strcat "\nError: " msg))
  ) ; if
  (princ)
) ;
 ;end error function
;;  pre set global variable, it remember your entry
(setq trimradius 0.066
      hump "Right") ; default


(defun C:bWire (/      enLine   entLine enCirc
    p1      p2       ang ang1 ptpick  centerPt
    linept   trimpt
   )
  (setq usercmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq useros (getvar "osmode"))
  (setq usrap (getvar "aperture"))
  (setvar "aperture" 50)
 
  ;;  loop until user presses Enter or Escape
  (setq loop T
status "On 0.067"
  )
  (while loop
    (setvar "osmode" 512)
    (setq usrprmpt
  (strcat
    "\nPick line to trim near intersection to trim:[Arcon/Off Radius Hump] "
    status
  )
    )
    (initget 6 "Arcon Off Radius Hump")
    (setq pt1 (getpoint usrprmpt))
    (cond
      ((= pt1 nil) ; user pressed enter
       (setq loop nil) ; exit
      )
      ((= pt1 "Radius") ; get new scale
       (initget 7) ; no error checking
       (setq trimradius (getreal "\nEnter new arc radius: "))
       (setq status (strcat "On " (rtos trimradius 2 2)))
      )
      ((= pt1 "Arcon")
       (setq status (strcat "On " (rtos trimradius 2 2)))
      )
      ((= pt1 "Off")
       (setq status "Off")
      )
      ((= pt1 "Hump") ; get new side for Hump
       (initget 1 "Left Right") ; no error checking
       (setq hump (getkword "\nLeave arc on the [Left Right] side of wire?"))
       ;(setq status (strcat "On " (rtos trimradius 2 2)))
      )


      (T ;point entered
       (setq ss (ssget pt1))
       (setq enLine
     (if ss
(list (ssname ss 0) pt1)
nil
     ) ;_ end of if
       )

       (if enLine
(progn
  (setq entLine (entget (car enLine)))
  (if (= (cdr (assoc 0 entLine)) "LINE")
    (progn
      (setq
p1 (Cdr (assoc 10 entLine))
p2 (Cdr (assoc 11 entLine))
ang (angle p1 p2)
ang1 ang
ptpick (cadr enLine)
      )
      (setvar "OSMODE" 0)
      (command "UNDO" "begin")
      (command "CIRCLE" "int" ptpick trimradius)
      (setq enCirc   (entlast)
    centerPt (cdr (assoc 10 (entget enCirc)))
      )

      (cond
((>= ang 4.70)
 (if (equal ang 4.7124 0.02)
   (setq ang (if (= hump "Left") (+ ang 0.10)(- ang 0.10)))
    (setq ang (- ang 0.10))
 )
)
((>= ang 1.55)
 (if (equal ang 1.5708 0.02)
   (setq ang (if (= hump "Left") (- ang 0.10)(+ ang 0.10)))
   (setq ang (+ ang 0.10))
 )
)
((>= ang 0)
 (setq ang (- ang 0.10))
)
      )

      (setq trimpt (polar centerPt ang (* trimradius 1.1))
    linept (polar centerPt ang1  (* trimradius 0.8))
      )
      (command "trim" enCirc "" linept "") ; trim line picked
      (if (/= status "Off") ; trim or erase arc
(command "trim"(car enLine) "" "F" centerPt trimpt "" "")
(entdel enCirc)
      )
      (command "UNDO" "end")

    ) ; end progn
    (prompt "\nNot a LINE selected.")
  ) ; endif
) ; end progn
(prompt "\nNothong Selected.")
       ) ; endif


      ) ; end cond T
    ) ; end cond
  ) ; end while
  (setvar "CMDECHO" usercmd)
  (setvar "osmode" useros)
  (setvar "aperture" usrap)
  (princ)
)
(prompt "\nBreak Wire loaded, Enter BWire to run.")
(princ)


[hendie]

I just remembered... this was the subject of my very first post over at the old swamp  

[CAB]

Perhaps this was the routine I was thinking of.

http://theswamp.org/phpBB2/viewtopic.php?t=382&highlight=crossing

[hendie]

heh.... but that version only works on lines ! the new version will trim arcs as well and loops better  

[Mark]

I just remembered... this was the subject of my very first post over at the old swamp  

I remember that. Don't have the code, but I remember that post.

[Keith™]

Ronjonp, you should really try out the proggie hendie added the link to. It is a comprehensive proggie that is very user friendly ....

and NO it does not cost money to get it....

but it does require that you register for download access.

[sinc]

Here's one I came up with a while back that was designed for creating intersections where four entities cross.  It breaks the objects at the crossing points.

It actually lets you select any number of entities (lines, arcs, polylines, splines), and then will erase the gap between intersections on all objects that cross two and only two of the other objects.  If you make a grid of lines and play with it, you should get a feel for how it works.  (It will also break circles, but with unpredictable results...)

Code: [Select]


; itrim.lsp  v1.01
; takes a selection set, and trims the gap between intersection points for
; all objects that intersect two and only two of the other objects in the set
; Richard Sincovec, July 11 2004
; Bug fixes - July 30, 2004

(vl-load-com)
(defun c:itrim (/ acadObj doc ssets ss count err
i j items item intxlist intitem
osmode
      )
  (setq osmode (getvar "osmode")
acadObj (vlax-get-acad-object)
doc (vla-get-activeDocument acadObj)
ssets (vla-get-selectionSets doc)
err (vl-catch-all-apply
 (function
   (lambda ()
     (setq ss (vla-add ssets "ZYZ_ITRIM"))
   ) ;lambda
 ) ;function
) ;vl-catch-all-apply
  ) ;setq
  (if (vl-catch-all-error-p err)
    ;; error is probably "ss already exists"
    ;; it shouldn't yet, but use it if it does
    (setq ss (vla-item ssets "ZYZ_ITRIM"))
  ) ;if
  (setq err (vl-catch-all-apply
     (function
(lambda ()
 (while ; (MAIN)
   (progn
     (vla-clear ss)
     (vla-selectOnScreen ss)
     (setq count (vla-get-count ss))
     (/= count 0)
   ) ;progn
    (setq i count
  items nil
    ) ;setq
    (setvar "osmode" 0)
    (while (/= i 0)
      (setq i      (1- i)
    item     (vla-item ss i)
    j      count
    intxlist nil
      ) ;setq
      (while (/= j 0)
(setq j       (1- j)
      intitem (vla-item ss j)
) ;setq
(if (/= (vla-get-handle item)
(vla-get-handle intitem)
    ) ;_ /=
  (progn
    (setq intx (vlax-variant-value
 (vla-IntersectWith
   item
   intitem
   acExtendNone
 ) ;_ vla-IntersectWith
) ;_ vlax-variant-value
    ) ;_ setq
    (if (safearray-value intx)
      (setq
intxlist
 (append
   intxlist
   (list (vlax-safearray->list intx))
 ) ;_ append
      ) ;setq
    ) ;_ if
  ) ;_ progn
) ;if
      ) ;while j
;; if we found two and only two intersections, store the entity for breaking
;; if we break it now, it will confuse the rest of the intersection checking
      (if (= (length intxlist) 2)
(setq
  items
   (append
     items
     (list (cons (vlax-vla-object->ename item)
 intxlist
   ) ;_ cons
     ) ;_ list
   ) ;_ append
) ;_ setq
      ) ;if
    ) ;while i
    ;; break the items
    (foreach item items
      (command "break"
(list (car item) (cadr item))
(caddr item)
      ) ;_ command
    ) ;foreach
 ) ;while (MAIN)
) ;lambda
     ) ;function
   ) ;vl-catch-all-apply
  ) ;setq
  (if (vl-catch-all-error-p err)
    (princ (vl-catch-all-error-message err))
  ) ;if
  (setvar "osmode" osmode)
  (vla-delete ss)
  (princ)
) ;defun