Is there a trace A>B polyline routine

[3dwannab]

I was looking to see if there was a trace polyline routine to pick a vertex of an existing polyline and pick a 2nd one along it to trace over it. No point in reinventing the wheel

 

I guess if it's a closed polyline then there would need to be a choice for the direction of the new traced polyline.

 

See the example drawing attached.

 

Polyline Trace.dwg

Edited March 29, 2023 by 3dwannab

[Emmanuel Delay]

You might need to first activate END, MID, NEAREST in osnap settings  (Command OS)

 

Then (osnap) is what you're looking for.

Happy with this?

 

(defun c:test ( / pt1)
    (setq pt1 (osnap (getpoint "\nSelect an endpoint: ") "_end,_mid,_nea"))
)

;;Osnap Mode	Meaning
;;"nea"	NEArest
;;"end"	ENDpoint
;;"mid"	MIDpoint
;;"cen"	CENter
;;"per"	PERpendicular
;;"tan"	TANgent
;;"qua"	QUAdrant
;;"ins"	INSertion
;;"po"	POint
;;"int"	INTersection (3D intersection)
;;"pla"	PLAnview (2D intersection)
;;"vis"	VISible (apparent intersection)
;;"off"	Off

 

[Tsuky]

You can try this...
You give the starting point.
Then with dexterity you pass the cursor over the existing path of the polyline and/or another polyline touching the first one (in the direction you want) without any click.
As you progress, a virtual segment (in red) will emerge...
When the last segment is drawn, you validate with a right-click

(defun round (num prec)
  (if (zerop (setq prec (abs prec)))
    num
    (* prec (fix ((if (minusp num) - +) (/ num prec) 0.5)))
  )
)
(defun c:cpoly_on_poly ( / p1 p2 key pt_sel ss ent obj_lw param_pt new_param pt lst_pt lst_gr)
  (initget 1)
  (setq
    p1 (getpoint "\nStart point: ")
    new_param nil
    ent nil
    lst_pt (list p1)
    lst_gr nil
  )
  (while (and (setq key (grread T 4 0)) (not (member key '((2 13) (2 32)))) (/= (car key) 25))
    (cond
      ((eq (car key) 5)
        (setq
          pt_sel (osnap (list (caadr key) (cadadr key)) "_near")
        )
        (if pt_sel
          (progn
            (setq ss (ssget "_C" pt_sel pt_sel '((0 . "LWPOLYLINE"))))
            (if ss (setq ent (ssname ss 0)))
          )
        )
        (cond
          (ent 
            (setq
              obj_lw (vlax-ename->vla-object ent)
              pt_sel (vlax-curve-getClosestPointTo obj_lw (trans (cadr key) 1 0))
            )
            (cond
              (pt_sel
                (setq
                  param_pt (vlax-curve-getParamAtPoint obj_lw pt_sel)
                  param_pt (round param_pt 1.0)
                )
                (cond
                  (new_param
                    (setq pt (vlax-curve-getPointAtParam obj_lw param_pt))
                    (if (and (not (eq param_pt new_param)) (not (member pt lst_pt)))
                      (progn
                        (setq lst_pt (cons (trans pt 0 1) lst_pt))
                        (setq p2 (trans pt 0 1))
                        (setq lst_gr (append (cons 1 (list p1 p2)) lst_gr))
                        (grvecs lst_gr)
                        (setq p1 p2)
                      )
                    )
                  )
                )
                (setq new_param param_pt)
              )
            )
          )
        )
      )
      ((member key '((2 117)(2 85)))
        (if lst_gr
          (setq
            lst_gr (cdddr lst_gr)
            lst_pt (cdr lst_pt)
            p1 (car lst_pt)
          )
        )
        (redraw)
        (grvecs lst_gr)
      )
      (T
        (if lst_gr (grvecs lst_gr))
      )
    )
  )
  (redraw)
  (cond
    (lst_pt
      (setvar "CMDECHO" 0)
      (command "_.pline")
      (foreach n lst_pt (command "_none" n))
      (command "")
      (setvar "CMDECHO" 1)
      (sssetfirst nil (ssadd (entlast)))
    )
  )
  (prin1)
)

 

Edited March 29, 2023 by Tsuky

[marko_ribar]

Study this topic entirely...

 

https://www.cadtutor.net/forum/topic/37726-draw-polyline-along-with-2-or-more-adjacent-closed-polylines/

 

HTH.

M.R.

[3dwannab]

4 hours ago, Tsuky said:

You can try this...
You give the starting point.
Then with dexterity you pass the cursor over the existing path of the polyline and/or another polyline touching the first one (in the direction you want) without any click.
As you progress, a virtual segment (in red) will emerge...
When the last segment is drawn, you validate with a right-click

...

 

 

Simply amazing work. Thank you so much!!

[ronjonp]

Another way to do this is create a copy then use the break command. Guess that would only work on closed polylines though.

Edited March 29, 2023 by ronjonp

[BIGAL]

ronjonp I meant to post this, "maybe copy existing then use a trim outside of the 2 pick points on the new pline", but went shopping 3 hours ago same idea.

 

Do like the grdraw method though.

[3dwannab]

Thanks everyone for your help but the grdraw method is everything plus more than what I was expecting. 

 

I've yet to look into trying my hand at it. I guess someday

[3dwannab]

On 3/29/2023 at 11:59 AM, Tsuky said:

You can try this...
You give the starting point.
Then with dexterity you pass the cursor over the existing path of the polyline and/or another polyline touching the first one (in the direction you want) without any click.
As you progress, a virtual segment (in red) will emerge...
When the last segment is drawn, you validate with a right-click

 

 

Hi @Tsuky, see the attached gif. I was wondering if is it much work to get it to work with arcs in POLYLINES? I wouldn't know where to start to get it to work. Thanks.

[Lee Mac]

You can use my Offset Polyline Section program and simply comment out lines 131-133 (inclusive).

[3dwannab]

Thanks @Lee Mac. What I love about Tsukys' is how you don't have to pick any Polyline and it allows the trace to go over multiple Polylines. But it's not without the arc issue or finding any intersections like below. 

 

I'd give anything to know how to fix these. I messed about with the snap for the variable pt_sel  with the below to try to fix this but nada.

 

EDIT: Looking at your http://www.lee-mac.com/grsnap.html atm. Seems like it could do what I want. Not sure though 

 

 

;; Tried to change this to fix the intersection bit

(setq pt_sel (osnap (list (caadr key) (cadadr key)) "_nearest"))

;; To

(or 
  (setq pt_sel (osnap (list (caadr key) (cadadr key)) "_nearest"))
  (setq pt_sel (osnap (list (caadr key) (cadadr key)) "_intersection"))
)

 

Edited July 10, 2023 by 3dwannab

[3dwannab]

Back to square one, sort of. Getting different results. Tried my best to incorporate the LM:grsnap:snapfunction function but it sort of taught me something. This level of coding is above me. 

 

Anyway. Here's the trace and the code below. I've commented where I'd added stuff with ;; 3dwannab Edit

 

(defun c:PT nil (c:Polyline_Trace))

; Answer by Tsuky to my question here:
; https://www.cadtutor.net/forum/topic/77215-is-there-a-trace-ab-polyline-routine/?do=findComment&comment=615720

(defun round (num prec) 
  (if (zerop (setq prec (abs prec))) 
    num
    (* prec (fix ((if (minusp num) - +) (/ num prec) 0.5)))
  )
)

(defun c:Polyline_Trace (/ p1 p2 key pt_sel ss ent obj_lw param_pt new_param pt lst_pt lst_gr) 
  (initget 1)
  (setq p1        (getpoint "\nStart point: ")
        new_param nil
        ent       nil
        lst_pt    (list p1)
        lst_gr    nil
  )

  ;; 3dwannab Edit: Added LeeMac code from: http://www.lee-mac.com/grsnap.html
  (setq osf (LM:grsnap:snapfunction) ;; Define optimised Object Snap function
        osm (getvar 'osmode) ;; Retrieve active Object Snap modes
  )

  ;; 3dwannab Edit: Added this. Note no undo handling to return this variable
  (setvar 'osmode 544) ;; Nearest and intersection

  (while 
    (and 

      (setq key (grread T 4 0))
      (not (member key '((2 13) (2 32))))
      (/= (car key) 25)

      ;; 3dwannab Edit: Added while cursor is moving
      (= 5 (car (setq grr (grread t 13 0))))
    )

    (cond 
      ((eq (car key) 5)
       (or 

         ;; 3dwannab Edit: Tried to add in intersection
         (setq pt_sel (osnap (list (caadr key) (cadadr key)) "_intersection"))
         (setq pt_sel (osnap (list (caadr key) (cadadr key)) "_near"))
       )
       (if pt_sel 
         (progn 
           (setq ss (ssget "_C" pt_sel pt_sel '((0 . "LWPOLYLINE"))))
           (if ss (setq ent (ssname ss 0)))
         )
       )
       (cond 
         (ent
          (setq obj_lw (vlax-ename->vla-object ent)
                
                ;; 3dwannab Edit: Changed the point to LeeMacs snap code
                pt_sel (vlax-curve-getClosestPointTo obj_lw (osf (cadr grr) osm))
          )
          (cond 
            (pt_sel
             (setq param_pt (vlax-curve-getParamAtPoint obj_lw pt_sel)
                   param_pt (round param_pt 1.0)
             )
             (cond 
               (new_param
                (setq pt (vlax-curve-getPointAtParam obj_lw param_pt))
                (if (and (not (eq param_pt new_param)) (not (member pt lst_pt))) 
                  (progn 
                    (setq lst_pt (cons (trans pt 0 1) lst_pt))
                    (setq p2 (trans pt 0 1))
                    (setq lst_gr (append (cons 1 (list p1 p2)) lst_gr))
                    (grvecs lst_gr)
                    (setq p1 p2)
                  )
                )
               )
             )
             (setq new_param param_pt)
            )
          )
         )
       )
      )
      ((member key '((2 117) (2 85)))
       (if lst_gr 
         (setq lst_gr (cdddr lst_gr)
               lst_pt (cdr lst_pt)
               p1     (car lst_pt)
         )
       )
       (redraw)
       (grvecs lst_gr)
      )
      (T
       (if lst_gr (grvecs lst_gr))
      )
    )
  )

  (redraw)
  (cond 
    (lst_pt
     (setvar "CMDECHO" 0)
     (command "_.pline")
     (foreach n lst_pt (command "_none" n))
     (command "")
     (setvar "CMDECHO" 1)
     (sssetfirst nil (ssadd (entlast)))
    )
  )
  (prin1)
)


;; 3dwannab Edit: Added LeeMacs' functions for grsnap

;; Object Snap for grread: Snap Function  -  Lee Mac
;; Returns: [fun] A function requiring two arguments:
;; p - [lst] UCS Point to be snapped
;; o - [int] Object Snap bit code
;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
;; or the supplied point if the snap failed for the given Object Snap bit code.

(defun LM:grsnap:snapfunction () 
  (eval 
    (list 'lambda 
          '(p o / q)
          (list 'if 
                '(zerop (logand 16384 o))
                (list 'if 
                      '(setq q (cdar 
                                 (vl-sort 
                                   (vl-remove-if 'null 
                                                 (mapcar 
                                                   (function 
                                                     (lambda (a / b) 
                                                       (if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a)))) 
                                                         (list (distance p b) b (car a))
                                                       )
                                                     )
                                                   )
                                                   '((0001 . "_end")
                                                     (0002 . "_mid")
                                                     (0004 . "_cen")
                                                     (0008 . "_nod")
                                                     (0016 . "_qua")
                                                     (0032 . "_int")
                                                     (0064 . "_ins")
                                                     (0128 . "_per")
                                                     (0256 . "_tan")
                                                     (0512 . "_nea")
                                                     (2048 . "_app")
                                                     (8192 . "_par")
                                                    )
                                                 )
                                   )
                                   '(lambda (a b) (< (car a) (car b)))
                                 )
                               )
                       )
                      (list 'LM:grsnap:displaysnap 
                            '(car q)
                            (list 'cdr 
                                  (list 'assoc 
                                        '(cadr q)
                                        (list 'quote 
                                              (LM:grsnap:snapsymbols 
                                                (atoi (cond ((getenv "AutoSnapSize")) ("5")))
                                              )
                                        )
                                  )
                            )
                            (LM:OLE->ACI 
                              (if (= 1 (getvar 'cvport)) 
                                (atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
                                (atoi (cond ((getenv "Model AutoSnap Color")) ("104193")))
                              )
                            )
                      )
                )
          )
          '(cond ((car q)) (p))
    )
  )
)

;; Object Snap for grread: Display Snap  -  Lee Mac
;; pnt - [lst] UCS point at which to display the symbol
;; lst - [lst] grvecs vector list
;; col - [int] ACI colour for displayed symbol
;; Returns nil

(defun LM:grsnap:displaysnap (pnt lst col / scl) 
  (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
        pnt (trans pnt 1 2)
  )
  (grvecs (cons col lst) 
          (list 
            (list scl 0.0 0.0 (car pnt))
            (list 0.0 scl 0.0 (cadr pnt))
            (list 0.0 0.0 scl 0.0)
            '(0.0 0.0 0.0 1.0)
          )
  )
)

;; Object Snap for grread: Snap Symbols  -  Lee Mac
;; p - [int] Size of snap symbol in pixels
;; Returns: [lst] List of vector lists describing each Object Snap symbol

(defun LM:grsnap:snapsymbols (p / -p -q -r a c i l q r) 
  (setq -p (- p)
        q  (1+ p)
        -q (- q)
        r  (+ 2 p)
        -r (- r)
        i  (/ pi 6.0)
        a  0.0
  )
  (repeat 12 
    (setq l (cons (list (* r (cos a)) (* r (sin a))) l)
          a (- a i)
    )
  )
  (setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
  (list 
    (list 1 
          (list -p -p)
          (list p -p)
          (list p -p)
          (list p p)
          (list p p)
          (list -p p)
          (list -p p)
          (list -p -p)
          (list -q -q)
          (list q -q)
          (list q -q)
          (list q q)
          (list q q)
          (list -q q)
          (list -q q)
          (list -q -q)
    )
    (list 2 
          (list -r -q)
          (list 0 r)
          (list 0 r)
          (list r -q)
          (list -p -p)
          (list p -p)
          (list p -p)
          (list 0 p)
          (list 0 p)
          (list -p -p)
          (list -q -q)
          (list q -q)
          (list q -q)
          (list 0 q)
          (list 0 q)
          (list -q -q)
    )
    (cons 4 c)
    (vl-list* 8 (list -r -r) (list r r) (list r -r) (list -r r) c)
    (list 16 
          (list p 0)
          (list 0 p)
          (list 0 p)
          (list -p 0)
          (list -p 0)
          (list 0 -p)
          (list 0 -p)
          (list p 0)
          (list q 0)
          (list 0 q)
          (list 0 q)
          (list -q 0)
          (list -q 0)
          (list 0 -q)
          (list 0 -q)
          (list q 0)
          (list r 0)
          (list 0 r)
          (list 0 r)
          (list -r 0)
          (list -r 0)
          (list 0 -r)
          (list 0 -r)
          (list r 0)
    )
    (list 32 
          (list r r)
          (list -r -r)
          (list r q)
          (list -q -r)
          (list q r)
          (list -r -q)
          (list -r r)
          (list r -r)
          (list -q r)
          (list r -q)
          (list -r q)
          (list q -r)
    )
    (list 64 
          '(0 1)
          (list 0 p)
          (list 0 p)
          (list -p p)
          (list -p p)
          (list -p -1)
          (list -p -1)
          '(0 -1)
          '(0 -1)
          (list 0 -p)
          (list 0 -p)
          (list p -p)
          (list p -p)
          (list p 1)
          (list p 1)
          '(0 1)
          '(1 2)
          (list 1 q)
          (list 1 q)
          (list -q q)
          (list -q q)
          (list -q -2)
          (list -q -2)
          '(-1 -2)
          '(-1 -2)
          (list -1 -q)
          (list -1 -q)
          (list q -q)
          (list q -q)
          (list q 2)
          (list q 2)
          '(1 2)
    )
    (list 128 
          (list (1+ -p) 0)
          '(0 0)
          '(0 0)
          (list 0 (1+ -p))
          (list (1+ -p) 1)
          '(1 1)
          '(1 1)
          (list 1 (1+ -p))
          (list -p q)
          (list -p -p)
          (list -p -p)
          (list q -p)
          (list -q q)
          (list -q -q)
          (list -q -q)
          (list q -q)
    )
    (vl-list* 256 (list -r r) (list r r) (list -r (1+ r)) (list r (1+ r)) c)
    (list 512 
          (list -p -p)
          (list p -p)
          (list -p p)
          (list p p)
          (list -q -q)
          (list q -q)
          (list q -q)
          (list -q q)
          (list -q q)
          (list q q)
          (list q q)
          (list -q -q)
    )
    (list 2048 
          (list -p -p)
          (list p p)
          (list -p p)
          (list p -p)
          (list (+ p 05) -p)
          (list (+ p 06) -p)
          (list (+ p 05) -q)
          (list (+ p 06) -q)
          (list (+ p 09) -p)
          (list (+ p 10) -p)
          (list (+ p 09) -q)
          (list (+ p 10) -q)
          (list (+ p 13) -p)
          (list (+ p 14) -p)
          (list (+ p 13) -q)
          (list (+ p 14) -q)
          (list -p -p)
          (list p -p)
          (list p -p)
          (list p p)
          (list p p)
          (list -p p)
          (list -p p)
          (list -p -p)
          (list -q -q)
          (list q -q)
          (list q -q)
          (list q q)
          (list q q)
          (list -q q)
          (list -q q)
          (list -q -q)
    )
    (list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
  )
)

;; Object Snap for grread: Parse Point  -  Lee Mac
;; bpt - [lst] Basepoint for relative point input, e.g. @5,5
;; str - [str] String representing point input
;; Returns: [lst] Point represented by the given string, else nil

(defun LM:grsnap:parsepoint (bpt str / str->lst lst) 

  (defun str->lst (str / pos) 
    (if (setq pos (vl-string-position 44 str)) 
      (cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
      (list str)
    )
  )

  (if (wcmatch str "`@*") 
    (setq str (substr str 2))
    (setq bpt '(0.0 0.0 0.0))
  )

  (if 
    (and 
      (setq lst (mapcar 'distof (str->lst str)))
      (vl-every 'numberp lst)
      (< 1 (length lst) 4)
    )
    (mapcar '+ bpt lst)
  )
)

;; Object Snap for grread: Snap Mode  -  Lee Mac
;; str - [str] Object Snap modifier
;; Returns: [int] Object Snap bit code for the given modifier, else nil

(defun LM:grsnap:snapmode (str) 
  (vl-some 
    (function 
      (lambda (x) 
        (if (wcmatch (car x) (strcat (strcase str t) "*")) 
          (progn 
            (princ (cadr x))
            (caddr x)
          )
        )
      )
    )
    '(("endpoint" " of " 00001)
      ("midpoint" " of " 00002)
      ("center" " of " 00004)
      ("node" " of " 00008)
      ("quadrant" " of " 00016)
      ("intersection" " of " 00032)
      ("insert" " of " 00064)
      ("perpendicular" " to " 00128)
      ("tangent" " to " 00256)
      ("nearest" " to " 00512)
      ("appint" " of " 02048)
      ("parallel" " to " 08192)
      ("none" "" 16384)
     )
  )
)

;; OLE -> ACI  -  Lee Mac
;; Args: c - [int] OLE Colour

(defun LM:OLE->ACI (c) 
  (apply 'LM:RGB->ACI (LM:OLE->RGB c))
)

;; OLE -> RGB  -  Lee Mac
;; Args: c - [int] OLE Colour

(defun LM:OLE->RGB (c) 
  (mapcar '(lambda (x) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)

;; RGB -> ACI  -  Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values

(defun LM:RGB->ACI (r g b / c o) 
  (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2)))) 
    (progn 
      (setq c (vl-catch-all-apply '(lambda () (vla-setrgb o r g b) (vla-get-colorindex o))))
      (vlax-release-object o)
      (if (vl-catch-all-error-p c) 
        (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
        c
      )
    )
  )
)

;; Application Object  -  Lee Mac
;; Returns the VLA Application Object

(defun LM:acapp nil 
  (eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
  (LM:acapp)
)

(vl-load-com)
(princ)

(c:pt)

 

 

Edited July 10, 2023 by 3dwannab