Draw Polyline with Specified Max. Length & Insert Text For Length

[JCYK]

Hi all,

 

I would like to ask for your help to create a lisp to facilitate the following task (FYI I'm not versed in creating lisp).

 

Sometimes we need to check floor plans to ensure all areas are within the max. fire escape travel distance (TD). I'll need to draw polylines (consists of few segments) from exit staircase entrance and see the max. TD can covers up to where. Each time I have to estimate the length as I draw the polyline, followed by go to properties to check the length, then adjust the polyline length, then check the length and keep repeating these steps until the polyline reached exactly the max. TD. And I have many of these polylines that I need to draw and is very time consuming. Fyi the max. TD can varies depending on the space usage.

 

As such it would be very helpful if there's a lisp to create polyline with the following function:

1. User defined max. distance that I can draw; 

2. While drawing the polyline, as the mouse cursor moves there's a live display of the total distance next to the cursor. This is to help us to know it has so far reached how much distance;

3. Once reached the final click where the max. distance has reached, polyline command ended and will ask for placement of text to display the distance (eg. 60m). As different projects/ plans will have different scale there needs to have an option for user to specify text height before placement. When drawing subsequent polylines the last specified text height will remain as default. Meaning when prompted for text height it will shows the last specified height as default, user just need to press enter if they don't wish to change the text height.

 

Appearance of Polyline/ Text:

4. Linetype: DASHED2 (acadiso.lin)

5. Polyline width: 50mm

6. Linetype Scale: 0.2

7. Layer: Use current

8. A circle of 200mm diameter to mark the start point of polyline; an arrow head to mark end of polyline (Refer to screenshot below and attachment).

9. Text Style: Arial

 

 

Any help on the above would be very much appreciated.

 

Many thanks in advance!

 

Polyline with Defined Distance.dwg

[Jonathan Handojo]

You want a polyline with an arrowhead? I'm not sure if I've heard that one before. However, it can be such that you just draw two polylines at the end that would facilitate as an arrowhead.

 

Oh, and also, what's the text height?

[dlanorh]

Not a complete solution, but a concept that needs more flesh on the bones. Makes use of @Lee Mac's GrText. Red portion of polyline is fixed green is to be fixed, text at cursor is total distance from start point of polyline to cursor position. It only draws the circle and polyline following the picked points as yet.

 

dynlenlwp.lsp

[Jonathan Handojo]

Here's my complete solution for you:

 

(defun c:tracepoly
       
       (/ *error*  05pi	    135deg   15pi     225deg   acadobj	activeundo	  adoc	   angpl
	  arrowhead_size    arrpl    coords   DegToRad dist	endpt	 gr	  grp	   grplpt
	  grv	   lastpt   maxlen   maxpt    midpt    msp	pl	 pt	  pts	   txt)

    (defun *error* ( msg )
	(vla-EndUndoMark adoc)
	(if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*"))
	    (princ (strcat "Error: " msg))
	    )
	)
    (defun midpt (p1 p2) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))   ; <--- Not applicable for 3D space
    (defun DegToRad (ang) (* (/ pi 180) ang))
    
    (setq acadobj (vlax-get-acad-object)
	  adoc (vla-get-ActiveDocument acadobj)
	  msp (vla-get-ModelSpace adoc)
	  activeundo nil)
    (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T))

    (setq arrowhead_size 125)	; <--- Set arrowhead size here
    
    (if
	(and
	    (setq dist (progn (initget 6) (getdist "\nSpecify maximum distance: ")))
	    (setq pt (getpoint "\nSpecify start point: "))
	    )
	(progn
	    (entmake
		(list
		    '(0 . "CIRCLE")
		    (cons 10 pt)
		    '(40 . 100)
		    )
		)
	    (setq pl
		     (vlax-ename->vla-object
			 (entmakex
			     (list
				 '(0 . "LWPOLYLINE")
				 '(100 . "AcDbEntity")
				 '(100 . "AcDbPolyline")
				 '(6 . "DASHED2")
				 '(48 . 0.2)
				 '(90 . 2)
				 '(70 . 0)
				 '(43 . 50.0)
				 (cons 10 pt)
				 '(40 . 50.0)
				 '(41 . 50.0)
				 '(42 . 0.0)
				 '(91 . 0)
				 (cons 10 (polar pt 0 1))
				 '(40 . 50.0)
				 '(41 . 50.0)
				 '(42 . 0.0)
				 '(91 . 0)
				 )
			     )
			 )
		  arrpl (vlax-ename->vla-object
			    (entmakex
				(list
				    '(0 . "LWPOLYLINE")
				    '(100 . "AcDbEntity")
				    '(100 . "AcDbPolyline")
				    '(6 . "DASHED2")
				    '(48 . 0.2)
				    '(90 . 2)
				    '(70 . 0)
				    '(43 . 50.0)
				    (cons 10 pt)
				    '(40 . 50.0)
				    '(41 . 50.0)
				    '(42 . 0.0)
				    '(91 . 0)
				    (cons 10 (polar pt 0 1))
				    '(40 . 50.0)
				    '(41 . 50.0)
				    '(42 . 0.0)
				    '(91 . 0)
				    )
				)
			    )
		  txt (vla-AddText msp "1m" (vlax-3d-point pt) 200)
		  pts (vlax-get pl 'Coordinates)
		  coords (list (car pts) (cadr pts))
		  lastpt (list (caddr pts) (cadddr pts))
		  05pi (* 0.5 pi)
		  15pi (* 1.5 pi)
		  135deg (DegToRad 135)
		  225deg (DegToRad 225)
		  )
	    (vla-put-Alignment txt acAlignmentMiddle)
	    (while
		(progn
		    (setq gr (grread t 15 0)
			  grp (last gr)
			  grv (car gr)
			  )
		    (cond
			((= grv 5)
			 (setq grplpt (list (car grp) (cadr grp))
			       angpl (angle lastpt grp)
			       )
			 (vlax-put pl 'Coordinates (append coords grplpt))
			 (if (> (setq maxlen (vla-get-Length pl)) dist)
			     (progn
				 (setq maxpt (vlax-curve-getPointAtDist pl dist))
				 (vlax-put pl 'Coordinates (append coords (list (car maxpt) (cadr maxpt))))
				 )
			     )
			 (setq endpt (vlax-curve-getEndPoint pl))
			 (vlax-put arrpl 'Coordinates
				   (apply 'append
					  (mapcar
					      '(lambda (x)
						   (list (car x) (cadr x))
						   )
					      (list
						  (polar endpt (+ angpl 135deg) arrowhead_size)
						  endpt
						  (polar endpt (+ angpl 225deg) arrowhead_size)
						  )
					      )
					  )
				   )
			 (vla-put-TextString txt (strcat (rtos (vla-get-Length pl) 2 1) "m"))
			 (vla-put-TextAlignmentPoint txt
			     (vlax-3d-point
				 (polar
				     (midpt lastpt endpt)
				     (+ 05pi angpl)
				     200
				     )
				 )
			     )
			 (vla-put-Rotation txt (+ angpl (if (<= 05pi angpl 15pi) pi 0)))
			 T
			 )
			((and (= grv 2) (vl-position grp '(13 32))) nil)
			((= grv 3)
			 (setq coords (append coords grplpt)
			       lastpt grplpt
			       )
			 (< maxlen dist)
			 )
			(T)
			)
		    )
		)
	    )
	)
    (if activeundo nil (vla-EndUndoMark adoc))
    (princ)
    )

 

[Lee Mac]

8 hours ago, JCYK said:

As such it would be very helpful if there's a lisp to create polyline with the following function:

1. User defined max. distance that I can draw; 

2. While drawing the polyline, as the mouse cursor moves there's a live display of the total distance next to the cursor. This is to help us to know it has so far reached how much distance;

 

My existing Limited Length Polyline program should accomplish these first two points.

[JCYK]

 

On 5/3/2020 at 7:43 PM, Jonathan Handojo said:

Here's my complete solution for you:

 

(defun c:tracepoly
       
       (/ *error*  05pi	    135deg   15pi     225deg   acadobj	activeundo	  adoc	   angpl
	  arrowhead_size    arrpl    coords   DegToRad dist	endpt	 gr	  grp	   grplpt
	  grv	   lastpt   maxlen   maxpt    midpt    msp	pl	 pt	  pts	   txt)

    (defun *error* ( msg )
	(vla-EndUndoMark adoc)
	(if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*"))
	    (princ (strcat "Error: " msg))
	    )
	)
    (defun midpt (p1 p2) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))   ; <--- Not applicable for 3D space
    (defun DegToRad (ang) (* (/ pi 180) ang))
    
    (setq acadobj (vlax-get-acad-object)
	  adoc (vla-get-ActiveDocument acadobj)
	  msp (vla-get-ModelSpace adoc)
	  activeundo nil)
    (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T))

    (setq arrowhead_size 125)	; <--- Set arrowhead size here
    
    (if
	(and
	    (setq dist (progn (initget 6) (getdist "\nSpecify maximum distance: ")))
	    (setq pt (getpoint "\nSpecify start point: "))
	    )
	(progn
	    (entmake
		(list
		    '(0 . "CIRCLE")
		    (cons 10 pt)
		    '(40 . 100)
		    )
		)
	    (setq pl
		     (vlax-ename->vla-object
			 (entmakex
			     (list
				 '(0 . "LWPOLYLINE")
				 '(100 . "AcDbEntity")
				 '(100 . "AcDbPolyline")
				 '(6 . "DASHED2")
				 '(48 . 0.2)
				 '(90 . 2)
				 '(70 . 0)
				 '(43 . 50.0)
				 (cons 10 pt)
				 '(40 . 50.0)
				 '(41 . 50.0)
				 '(42 . 0.0)
				 '(91 . 0)
				 (cons 10 (polar pt 0 1))
				 '(40 . 50.0)
				 '(41 . 50.0)
				 '(42 . 0.0)
				 '(91 . 0)
				 )
			     )
			 )
		  arrpl (vlax-ename->vla-object
			    (entmakex
				(list
				    '(0 . "LWPOLYLINE")
				    '(100 . "AcDbEntity")
				    '(100 . "AcDbPolyline")
				    '(6 . "DASHED2")
				    '(48 . 0.2)
				    '(90 . 2)
				    '(70 . 0)
				    '(43 . 50.0)
				    (cons 10 pt)
				    '(40 . 50.0)
				    '(41 . 50.0)
				    '(42 . 0.0)
				    '(91 . 0)
				    (cons 10 (polar pt 0 1))
				    '(40 . 50.0)
				    '(41 . 50.0)
				    '(42 . 0.0)
				    '(91 . 0)
				    )
				)
			    )
		  txt (vla-AddText msp "1m" (vlax-3d-point pt) 200)
		  pts (vlax-get pl 'Coordinates)
		  coords (list (car pts) (cadr pts))
		  lastpt (list (caddr pts) (cadddr pts))
		  05pi (* 0.5 pi)
		  15pi (* 1.5 pi)
		  135deg (DegToRad 135)
		  225deg (DegToRad 225)
		  )
	    (vla-put-Alignment txt acAlignmentMiddle)
	    (while
		(progn
		    (setq gr (grread t 15 0)
			  grp (last gr)
			  grv (car gr)
			  )
		    (cond
			((= grv 5)
			 (setq grplpt (list (car grp) (cadr grp))
			       angpl (angle lastpt grp)
			       )
			 (vlax-put pl 'Coordinates (append coords grplpt))
			 (if (> (setq maxlen (vla-get-Length pl)) dist)
			     (progn
				 (setq maxpt (vlax-curve-getPointAtDist pl dist))
				 (vlax-put pl 'Coordinates (append coords (list (car maxpt) (cadr maxpt))))
				 )
			     )
			 (setq endpt (vlax-curve-getEndPoint pl))
			 (vlax-put arrpl 'Coordinates
				   (apply 'append
					  (mapcar
					      '(lambda (x)
						   (list (car x) (cadr x))
						   )
					      (list
						  (polar endpt (+ angpl 135deg) arrowhead_size)
						  endpt
						  (polar endpt (+ angpl 225deg) arrowhead_size)
						  )
					      )
					  )
				   )
			 (vla-put-TextString txt (strcat (rtos (vla-get-Length pl) 2 1) "m"))
			 (vla-put-TextAlignmentPoint txt
			     (vlax-3d-point
				 (polar
				     (midpt lastpt endpt)
				     (+ 05pi angpl)
				     200
				     )
				 )
			     )
			 (vla-put-Rotation txt (+ angpl (if (<= 05pi angpl 15pi) pi 0)))
			 T
			 )
			((and (= grv 2) (vl-position grp '(13 32))) nil)
			((= grv 3)
			 (setq coords (append coords grplpt)
			       lastpt grplpt
			       )
			 (< maxlen dist)
			 )
			(T)
			)
		    )
		)
	    )
	)
    (if activeundo nil (vla-EndUndoMark adoc))
    (princ)
    )

 

 

@Jonathan Handojo, omg you made my dream comes true!!  Can I trouble you to make some refinement to the lisp as follow : 

 

1. Currently the final distance displayed is in mm although the unit shown is in metre (eg. should be 5m instead of 5000m). Can help to make it displays in metre (eg. 5m)? My drawing unit is in mm, fyi.

2. Can make the default text style as Arial?

3. Possible to allow polar / orthomode to be able to turned on during the command?

4. Can make the arrowhead close-end (see green arrowhead below) instead of open-end? This is very minor if can't be done it's fine.

 

5. I'll need to use this on different scale plans (eg. 1:100 and 1:300). What we have now in the lisp is actually suitable for 1:100 scale plan display, when used on 1:300 scale plan the line type will look too dense, text/arrowhead/circle will be too small. Is it possible at the start of the command it'll ask user to select the scale (100 or 300)? This should only be prompted once when the command is first used on the drawing. Meaning it will not keep prompting this in subsequent use of the command in the same drawing.

 

Settings for 1:300 scale:

6. Linetype: DASHED2 (acadiso.lin)

7. Polyline width: 100mm

8. Linetype Scale: 1

9. Layer: Use current

10. A circle (continuous linetype) of 400mm diameter to mark the start point of polyline; an arrowhead (continuous linetype) 3x the size of that in 1:100, to mark end of polyline (Refer to screenshot below and attachment).

11. Text Style: Arial

 

Many thanks in advance! 

 

 

[CAD_Noob]

28 minutes ago, JCYK said:

 

 

@Jonathan Handojo, omg you made my dream comes true!!  Can I trouble you to make some refinement to the lisp as follow : 

 

1. Currently the final distance displayed is in mm although the unit shown is in metre (eg. should be 5m instead of 5000m). Can help to make it displays in metre (eg. 5m)? My drawing unit is in mm, fyi.

2. Can make the default text style as Arial?

3. Possible to allow polar / orthomode to be able to turned on during the command?

4. Can make the arrowhead close-end (see green arrowhead below) instead of open-end? This is very minor if can't be done it's fine.

 

5. I'll need to use this on different scale plans (eg. 1:100 and 1:300). What we have now in the lisp is actually suitable for 1:100 scale plan display, when used on 1:300 scale plan the line type will look too dense, text/arrowhead/circle will be too small. Is it possible at the start of the command it'll ask user to select the scale (100 or 300)? This should only be prompted once when the command is first used on the drawing. Meaning it will not keep prompting this in subsequent use of the command in the same drawing.

 

Settings for 1:300 scale:

6. Linetype: DASHED2 (acadiso.lin)

7. Polyline width: 100mm

8. Linetype Scale: 1

9. Layer: Use current

10. A circle (continuous linetype) of 400mm diameter to mark the start point of polyline; an arrowhead (continuous linetype) 3x the size of that in 1:100, to mark end of polyline (Refer to screenshot below and attachment).

11. Text Style: Arial

 

Many thanks in advance! 

 

 

 

I'm assuming this will be used as running distance for fire escape plans. 

Would be helpful if it is already set on a particular layer .

[JCYK]

On 5/3/2020 at 6:59 PM, dlanorh said:

Not a complete solution, but a concept that needs more flesh on the bones. Makes use of @Lee Mac's GrText. Red portion of polyline is fixed green is to be fixed, text at cursor is total distance from start point of polyline to cursor position. It only draws the circle and polyline following the picked points as yet.

 

dynlenlwp.lsp 20.25 kB · 6 downloads

 

Hi @dlanorh, thank you for your help! Although not a complete solution I believed it is still helpful to some who just need those function.

 

On 5/4/2020 at 1:43 AM, Lee Mac said:

 

My existing Limited Length Polyline program should accomplish these first two points.

 

Hi @Lee Mac, thank you for sharing this great lisp that you have! As @Jonathan Handojo has created one very close to what I need, I would base on that and see if he can help further refine it as per my earlier post. Thank you once again.

[dlanorh]

Attached working version if you're interested. Arial textstyle must be defined. Will work in imperial or metric.

dynlenlwp2.lsp

[Jonathan Handojo]

21 hours ago, JCYK said:

Can I trouble you to make some refinement to the lisp as follow : 

 

No, you may not....  Just kidding 

 

 

I've managed to fix all issues you got except for a few...

 

1. The green arrowhead. I'm not sure how to actually solve that one.

2. I've not included an ortho option since I believe the polar tracking will be enough.

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                                              ;;;
;;;  Tracepoly Instructions                                                                      ;;;
;;;                                                                                              ;;;
;;;  Default values and scales can be set up below. Find "TRACEPOLY SETUP" and specify defaults  ;;;
;;;  as necessary.                                                                               ;;;
;;;                                                                                              ;;;
;;;  When tracing the polyline,                                                                  ;;;
;;;                                                                                              ;;;
;;;  [+] to increase scale in the setup                                                          ;;;
;;;  [-] to decrease scale in the setup                                                          ;;;
;;;  [T] to toggle between measurement detail                                                    ;;;
;;;  [Space] or [Enter] to accept polyline at the location of the mouse cursor (unless it        ;;;
;;;  reached the limit)                                                                          ;;;
;;;  [F10] to toggle Polar Tracking mode. Angle can be altered while tracing the polyline.       ;;;
;;;                                                                                              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:tracepoly
       
       (/ *error*   05pi      135deg	15pi	  225deg    45deg     acadobj	activepolar
	  activeundo	      adoc	angpl	  arrowhead_size      arrpl	circ	  coords
	  crosscolor	      curdets	degtorad  dets	    dist      endpt	getdet	  gr
	  grp	    grplpt    grv	lastpt	  lay	    lim	      maxlen	maxpt	  midpt
	  msg	    msp	      pl	pt	  pts	    sctxt     sindx	trackcolor
	  txt	    txthgt    units)
    
    (defun *error* ( msg )
	(if (eq (type sctxt) 'ename) (entdel sctxt))
	(vla-EndUndoMark adoc)
	(if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*"))
	    (princ (strcat "Error: " msg))
	    )
	)
    (defun midpt (p1 p2) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))   ; <--- Not applicable for 3D space
    (defun DegToRad (ang) (* (/ pi 180) ang))
    (defun getdet (scale tag / catch)
	(setq catch (nth (vl-position tag (car dets)) (assoc scale dets)))
	(cond
	    ((= tag "Diameter") (/ (float catch) 2))
	    ((= tag "Linetype")
	     (if (null (tblsearch "ltype" catch)) "Continuous" catch)
	     )
	    ((= tag "Layer")
	     (if
		 (or
		     (null catch)
             (null (tblsearch "layer" catch))
		     (null (zerop (cdr (assoc 70 (tblsearch "layer" catch)))))
		     (minusp (cdr (assoc 62 (tblsearch "layer" catch))))
		     )
		 (getvar 'clayer)
		 catch
		 )
	     )
	    ((= tag "Text Style")
	     (if (null (tblsearch "style" catch)) "Standard" catch)
	     )
	    (catch)
	    )
	)
    (setq acadobj (vlax-get-acad-object)
	  adoc (vla-get-ActiveDocument acadobj)
	  msp (vla-get-ModelSpace adoc)
	  activeundo nil)
    (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T))


    ;;; ------------------------------------- TRACEPOLY SETUP ------------------------------------- ;;;
    
    (setq
	arrowhead_size 125	 ; <--- Set arrowhead size here
	trackcolor acGreen  ; <--- Polar AutoTrack color
	crosscolor acYellow ; <--- Polar Snap color 
	dets
	   '(
	     ( ;|1.|; "Scale" ;|2.|; "Linetype" ;|3.|; "Line Width" ;|4.|; "Linetype Scale" ;|5.|; "Layer" ;|6.|; "Diameter" ;|7|; "Text Style" ;|8.|; "Text Height")
	     
	     ; DO NOT DELETE OR CHANGE THE ABOVE (Except maybe for the inner comment)
	     ; If linetype (2) does not exist, "Continuous" will be used
	     ; If layer supplied (5) is nil, doesn't exist, locked, off, or frozen, current layer will be used
	     ; If text style (7) does not exist, "Standard" will be used
	     ; Add more list below if you want to use more scales. Feel free to modify as well if it's not according to your taste
	     
	     (50 "DASHED2" 30 50 nil 100 "Arial" 200)
	     (100 "DASHED2" 50 10 "TraceIt" 200 "Arial" 200)
	     (300 "DASHED2" 60 30 nil 400 "Arial" 200)
	     )

	units '("mm" "cm" "m")
	)

    ;;; ------------------------------------- TRACEPOLY SETUP ------------------------------------- ;;;

    (if
	(and
	    (null (and (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer)))))) (null (alert "\nPlease unlock the current layer before proceeding"))))
	    (setq dist (progn (initget 6) (getdist "\nSpecify maximum distance in millimeters: ")))
	    (setq pt (getpoint "\nSpecify start point: "))
	    )
	(progn
	    (setq txthgt (* 0.02 (getvar 'viewsize))
		  circ
		     (entmakex
			 (list
			     '(0 . "CIRCLE")
			     (cons 8 (getdet (caadr dets) "Layer"))
			     (cons 10 pt)
			     (cons 40 (getdet (caadr dets) "Diameter"))
			     )
			 )
		  pl
		     (vlax-ename->vla-object
			 (entmakex
			     (list
				 '(0 . "LWPOLYLINE")
				 '(100 . "AcDbEntity")
				 '(100 . "AcDbPolyline")
				 (cons 6 (getdet (caadr dets) "Linetype"))
				 (cons 48 (getdet (caadr dets) "Linetype Scale"))
				 '(90 . 2)
				 '(70 . 0)
				 (cons 43 (getdet (caadr dets) "Line Width"))
				 (cons 8 (getdet (caadr dets) "Layer"))
				 (cons 10 pt)
				 (cons 40 (getdet (caadr dets) "Line Width"))
				 (cons 41 (getdet (caadr dets) "Line Width"))
				 '(42 . 0.0)
				 '(91 . 0)
				 (cons 10 (polar pt 0 1))
				 (cons 40 (getdet (caadr dets) "Line Width"))
				 (cons 41 (getdet (caadr dets) "Line Width"))
				 '(42 . 0.0)
				 '(91 . 0)
				 )
			     )
			 )
		  arrpl (vlax-ename->vla-object
			    (entmakex
				(list
				    '(0 . "LWPOLYLINE")
				    '(100 . "AcDbEntity")
				    '(100 . "AcDbPolyline")
				    '(6 . "Continuous")
				    '(90 . 2)
				    '(70 . 0)
				    (cons 43 (getdet (caadr dets) "Line Width"))
				    (cons 8 (getdet (caadr dets) "Layer"))
				    (cons 10 pt)
				    (cons 40 (getdet (caadr dets) "Line Width"))
				    (cons 41 (getdet (caadr dets) "Line Width"))
				    '(42 . 0.0)
				    '(91 . 0)
				    (cons 10 (polar pt 0 1))
				    (cons 40 (getdet (caadr dets) "Line Width"))
				    (cons 41 (getdet (caadr dets) "Line Width"))
				    '(42 . 0.0)
				    '(91 . 0)
				    )
				)
			    )
		  sctxt (entmakex
			    (list
				'(0 . "TEXT")
				'(100 . "AcDbEntity")
				'(100 . "AcDbText")
				(cons 8 (getdet (caadr dets) "Layer"))
				(cons 10 pt)
				(cons 1 (strcat "Current scale - 1:" (itoa (caadr dets))))
				(cons 40 txthgt)
				'(50 . 0.0)
				(cons 7 (getdet (caadr dets) "Text Style"))
				)
			    )
		  txt (vla-AddText msp "x" (vlax-3d-point pt) 200)
		  pts (vlax-get pl 'Coordinates)
		  coords (list (car pts) (cadr pts))
		  lastpt (list (caddr pts) (cadddr pts))
		  05pi (* 0.5 pi)
		  15pi (* 1.5 pi)
		  45deg (DegToRad 45)
		  135deg (DegToRad 135)
		  225deg (DegToRad 225)
		  sindx 1
		  curdets (nth sindx dets)
		  lim (1- (length dets))
		  activepolar (if (= (logand 8 (getvar 'autosnap)) 8) T)
		  msg "\nSpecify next point \n[+] to increase scale, [-] to reduce scale, [Space] or [Enter] to end at mouse distance"
		  )
	    (vla-put-Alignment txt acAlignmentMiddle)
	    (vla-put-StyleName txt (getdet (caadr dets) "Text Style"))
	    (princ msg)
	    (while
		(progn
		    (setq gr (grread t 15 0)
			  grp (last gr)
			  grv (car gr)
			  )
		    (cond
			((= grv 5)
			 (redraw)
			 (setq txthgt (* 0.02 (getvar 'viewsize)))
			 (entmod
			     (JH:SubstThrough
				 (list
				     (cons 10 (polar grp 45deg txthgt))
				     (cons 40 txthgt)
				     )
				 '(lambda (x) (vl-position (car x) '(10 40)))
				 (entget sctxt)
				 )
			     )
			 (setq grp (JH:grpolar (list (cadr (reverse coords)) (last coords) 0.0) grp 0.01 acGreen acYellow)
			       grplpt (list (car grp) (cadr grp))
			       angpl (angle lastpt grp)
			       )
			 (vlax-put pl 'Coordinates (append coords grplpt))
			 (if (> (setq maxlen (vla-get-Length pl)) dist)
			     (progn
				 (setq maxpt (vlax-curve-getPointAtDist pl dist))
				 (vlax-put pl 'Coordinates (append coords (list (car maxpt) (cadr maxpt))))
				 )
			     )
			 (setq endpt (vlax-curve-getEndPoint pl))
			 (vlax-put arrpl 'Coordinates
				   (apply 'append
					  (mapcar
					      '(lambda (x)
						   (list (car x) (cadr x))
						   )
					      (list
						  (polar endpt (+ angpl 135deg) arrowhead_size)
						  endpt
						  (polar endpt (+ angpl 225deg) arrowhead_size)
						  )
					      )
					  )
				   )
			 (vla-put-TextString txt (strcat (rtos (cvunit (vla-get-Length pl) "mm" (car units)) 2 1) (car units)))
			 (vla-put-TextAlignmentPoint txt
			     (vlax-3d-point
				 (polar
				     (midpt lastpt endpt)
				     (+ 05pi angpl)
				     200
				     )
				 )
			     )
			 (vla-put-Rotation txt (+ angpl (if (<= 05pi angpl 15pi) pi 0)))
			 T
			 )
			((= grv 2)
			 (cond
			     ((vl-position grp '(13 32)) nil)	; <--- Enter or Space is pressed
			     ((vl-position grp '(43 61))	; <-- + or = is pressed
			      (if (= sindx lim) (princ "\nNo larger scale found")
				  (progn
				      (setq sindx (1+ sindx) curdets (nth sindx dets) lay (cons 8 (getdet (car curdets) "Layer")))
				      (entmod
					  (JH:SubstThrough
					      (list lay (cons 40 (getdet (car curdets) "Diameter")))
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget circ)
					      )
					  )
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 6 (getdet (car curdets) "Linetype"))
						  (cons 48 (getdet (car curdets) "Linetype Scale"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 6 48)))
					      (entget (vlax-vla-object->ename pl))
					      )
					  )
				      (entmod (JH:SubstThrough (list lay) '(lambda (x) (= (car x) 8)) (entget (vlax-vla-object->ename arrpl))))
				      (vla-put-ConstantWidth pl (getdet (car curdets) "Line Width"))
				      (vla-put-ConstantWidth arrpl (getdet (car curdets) "Line Width"))
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 40 (getdet (car curdets) "Text Height"))
						  (cons 7 (getdet (car curdets) "Text Style"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget (vlax-vla-object->ename txt))
					      )
					  )
				      (entmod
					  (subst
					      (cons 1 (strcat "Current scale - 1:" (itoa (car curdets))))
					      (assoc 1 (entget sctxt))
					      (entget sctxt)
					      )
					  )
				      )
				  )
			      (princ msg)
			      )
			     ((= grp 45)	; <--- - is pressed
			      (if (= sindx 1) (princ "\nNo smaller scale found")
				  (progn
				      (setq sindx (1- sindx) curdets (nth sindx dets) lay (cons 8 (getdet (car curdets) "Layer")))
				      (entmod
					  (JH:SubstThrough
					      (list lay (cons 40 (getdet (car curdets) "Diameter")))
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget circ)
					      )
					  )
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 6 (getdet (car curdets) "Linetype"))
						  (cons 48 (getdet (car curdets) "Linetype Scale"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 6 48)))
					      (entget (vlax-vla-object->ename pl))
					      )
					  )
				      (entmod (JH:SubstThrough (list lay) '(lambda (x) (= (car x) 8)) (entget (vlax-vla-object->ename arrpl))))
				      (vla-put-ConstantWidth pl (getdet (car curdets) "Line Width"))
				      (vla-put-ConstantWidth arrpl (getdet (car curdets) "Line Width"))
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 40 (getdet (car curdets) "Text Height"))
						  (cons 7 (getdet (car curdets) "Text Style"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget (vlax-vla-object->ename txt))
					      )
					  )
				      (entmod
					  (subst
					      (cons 1 (strcat "Current scale - 1:" (itoa (car curdets))))
					      (assoc 1 (entget sctxt))
					      (entget sctxt)
					      )
					  )
				      )
				  )
			      (princ msg)
			      )
			     ((= grp 21)	; F10 is pressed (polar tracking)
			      (if activepolar
				  (progn (setq activepolar nil) (setvar 'autosnap (- (getvar 'autosnap) 8)))
				  (progn (setq activepolar T) (setvar 'autosnap (+ (getvar 'autosnap) 8)))
				  )
			      T
			      )
			     ((vl-position grp '(84 116))	; T is pressed
			      (setq units (append (cdr units) (list (car units))))
			      )
			     (T)
			     )
			 )
			((= grv 3)
			 (setq coords (append coords grplpt)
			       lastpt grplpt
			       )
			 (< maxlen dist)
			 )
			(T)
			)
		    )
		)
	    (redraw)
	    (entdel sctxt)
	    )
	)

    (if activeundo nil (vla-EndUndoMark adoc))
    (princ)
    )


;; JH:SubstThrough --> Jonathan Handojo
;; Substitutes all items in a list that passes the predicate function for
;; every item in a second list. If the second list runs out, returns the
;; substituted list followed with the remainder of the original list.
;;
;; itmlist - list containing substitution items
;; func - function that accepts one argument representing each element
;;        in the list to be evaluated
;; lst - list to evaluate and substitute
;;
;; Example call:
;; _$ (JH:SubstThrough '("A" "B" "C" "D") '(lambda (x) (or (<= 3 x 4) (>= x 7))) '(0 1 2 3 4 5 6 7 8 9 10))
;; (0 1 2 "A" "B" 5 6 "C" "D" 9 10)

(defun JH:SubstThrough (itmlst func lst)
    (setq itmlst (cons nil itmlst))
    (mapcar
	'(lambda (arg)
	     (if (and (cdr itmlst) ((eval func) arg))
		 (car (setq itmlst (cdr itmlst)))
		 arg
		 )
	     )
	lst
	)
    )

;; JH:grpolar --> Jonathan Handojo
;; Constructs a polar vector and the cross denoting the snap point to the polar
;; Returns either the snapped point to the polar tracking if found or the supplied
;; relative point if failed.
;; -------------------------
;; bpt - base point
;; ppt - relative point
;; pix - snap distance ratio (value as (/ <actual_length_on_screen> (getvar 'viewsize)))... 0.01 is a nice value. 
;; coltrack - color of the polar tracking line (ACI index)
;; colsnap - color of the cross formed by the snap (ACI index)
;; -------------------------
;; Only to work in WCS.

(defun JH:grpolar (bpt ppt pix coltrack colsnap / 45rad 90rad ang dis s snaps)
    (setq ang (getvar 'polarang)
	  90rad (* 0.5 pi)
	  45rad (* (/ pi 180) 45)
	  dis (* 1.15 pix (getvar 'viewsize))
	  s (- ang))
    (repeat (fix (/ (* 2 pi) ang))
	(setq snaps (cons (setq s (+ ang s)) snaps))
	)
    (if (= 8 (logand 8 (getvar 'autosnap)))
	(cond
	    (
	     (vl-some
		 '(lambda (x / catch)
		      (if
			  (equal
			      ppt
			      (setq catch (inters bpt (polar bpt x 100) ppt (polar ppt (+ 90rad x) 100) nil))
			      dis
			      )
			  (progn
			      (grvecs
				  (list coltrack bpt (polar bpt (angle bpt catch) (* 10 (getvar 'viewsize)))
					colsnap (polar catch 45rad dis) (polar catch (+ 45rad pi) dis)
					colsnap (polar catch (+ 45rad 90rad) dis) (polar catch (+ 45rad 90rad 90rad 90rad) dis)
					)
				  '((1.0 0.0 0.0 0.0)
				    (0.0 1.0 0.0 0.0)
				    (0.0 0.0 1.0 0.0)
				    (0.0 0.0 0.0 1.0))
				  )
			      catch
			      )
			  )
		      )
		 snaps
		 )
	     )
	    (ppt)
	    )
	ppt
	)
    )

I've never actually posted something this long before to CADTutor, hopefully it's of some use to you and others who might need it. Unfortunately it would work only in WCS. (Not tested on UCS, but I'm pretty sure it will fail in terms of the GrPolar. Unless someone wants to refine it, but that's to the best of my abilities already.

 

Edited May 5, 2020 by Jonathan Handojo

[dlanorh]

2 hours ago, Jonathan Handojo said:

1. The green arrowhead. I'm not sure how to actually solve that one.

 

 

Make sure the arrowhead polyline is explicitly linetype continuous

[JCYK]

On 5/5/2020 at 6:30 PM, dlanorh said:

Attached working version if you're interested. Arial textstyle must be defined. Will work in imperial or metric.

dynlenlwp2.lsp 7.2 kB · 6 downloads

Hi @dlanorh, your working version looks awesome . It's interesting to see using different methods achieving same result. Will you be further developing it? Really looking forward to see the end product.   Thank you!

[dlanorh]

23 minutes ago, JCYK said:

Hi @dlanorh, your working version looks awesome . It's interesting to see using different methods achieving same result. Will you be further developing it? Really looking forward to see the end product.   Thank you!

 

Thank you. I can't think of anyway to develop it further at present, although suggestions are always welcome. It was originally designed to calculate delivery route distances for heavy equipment (safes, ATM's etc) across wooden suspended floors/basement area and allowed the operator to dynamically extract distances for the insertion of photographs denoting problems and the positioning of spreader plates etc.

[JCYK]

On 5/6/2020 at 1:22 AM, Jonathan Handojo said:

 

No, you may not....  Just kidding 

 

 

I've managed to fix all issues you got except for a few...

 

1. The green arrowhead. I'm not sure how to actually solve that one.

2. I've not included an ortho option since I believe the polar tracking will be enough.

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                                              ;;;
;;;  Tracepoly Instructions                                                                      ;;;
;;;                                                                                              ;;;
;;;  Default values and scales can be set up below. Find "TRACEPOLY SETUP" and specify defaults  ;;;
;;;  as necessary.                                                                               ;;;
;;;                                                                                              ;;;
;;;  When tracing the polyline,                                                                  ;;;
;;;                                                                                              ;;;
;;;  [+] to increase scale in the setup                                                          ;;;
;;;  [-] to decrease scale in the setup                                                          ;;;
;;;  [T] to toggle between measurement detail                                                    ;;;
;;;  [Space] or [Enter] to accept polyline at the location of the mouse cursor (unless it        ;;;
;;;  reached the limit)                                                                          ;;;
;;;  [F10] to toggle Polar Tracking mode. Angle can be altered while tracing the polyline.       ;;;
;;;                                                                                              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:tracepoly
       
       (/ *error*   05pi      135deg	15pi	  225deg    45deg     acadobj	activepolar
	  activeundo	      adoc	angpl	  arrowhead_size      arrpl	circ	  coords
	  crosscolor	      curdets	degtorad  dets	    dist      endpt	getdet	  gr
	  grp	    grplpt    grv	lastpt	  lay	    lim	      maxlen	maxpt	  midpt
	  msg	    msp	      pl	pt	  pts	    sctxt     sindx	trackcolor
	  txt	    txthgt    units)
    
    (defun *error* ( msg )
	(if (eq (type sctxt) 'ename) (entdel sctxt))
	(vla-EndUndoMark adoc)
	(if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*"))
	    (princ (strcat "Error: " msg))
	    )
	)
    (defun midpt (p1 p2) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))   ; <--- Not applicable for 3D space
    (defun DegToRad (ang) (* (/ pi 180) ang))
    (defun getdet (scale tag / catch)
	(setq catch (nth (vl-position tag (car dets)) (assoc scale dets)))
	(cond
	    ((= tag "Diameter") (/ (float catch) 2))
	    ((= tag "Linetype")
	     (if (null (tblsearch "ltype" catch)) "Continuous" catch)
	     )
	    ((= tag "Layer")
	     (if
		 (or
		     (null catch)
             (null (tblsearch "layer" catch))
		     (null (zerop (cdr (assoc 70 (tblsearch "layer" catch)))))
		     (minusp (cdr (assoc 62 (tblsearch "layer" catch))))
		     )
		 (getvar 'clayer)
		 catch
		 )
	     )
	    ((= tag "Text Style")
	     (if (null (tblsearch "style" catch)) "Standard" catch)
	     )
	    (catch)
	    )
	)
    (setq acadobj (vlax-get-acad-object)
	  adoc (vla-get-ActiveDocument acadobj)
	  msp (vla-get-ModelSpace adoc)
	  activeundo nil)
    (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T))


    ;;; ------------------------------------- TRACEPOLY SETUP ------------------------------------- ;;;
    
    (setq
	arrowhead_size 125	 ; <--- Set arrowhead size here
	trackcolor acGreen  ; <--- Polar AutoTrack color
	crosscolor acYellow ; <--- Polar Snap color 
	dets
	   '(
	     ( ;|1.|; "Scale" ;|2.|; "Linetype" ;|3.|; "Line Width" ;|4.|; "Linetype Scale" ;|5.|; "Layer" ;|6.|; "Diameter" ;|7|; "Text Style" ;|8.|; "Text Height")
	     
	     ; DO NOT DELETE OR CHANGE THE ABOVE (Except maybe for the inner comment)
	     ; If linetype (2) does not exist, "Continuous" will be used
	     ; If layer supplied (5) is nil, doesn't exist, locked, off, or frozen, current layer will be used
	     ; If text style (7) does not exist, "Standard" will be used
	     ; Add more list below if you want to use more scales. Feel free to modify as well if it's not according to your taste
	     
	     (50 "DASHED2" 30 50 nil 100 "Arial" 200)
	     (100 "DASHED2" 50 10 "TraceIt" 200 "Arial" 200)
	     (300 "DASHED2" 60 30 nil 400 "Arial" 200)
	     )

	units '("mm" "cm" "m")
	)

    ;;; ------------------------------------- TRACEPOLY SETUP ------------------------------------- ;;;

    (if
	(and
	    (null (and (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer)))))) (null (alert "\nPlease unlock the current layer before proceeding"))))
	    (setq dist (progn (initget 6) (getdist "\nSpecify maximum distance in millimeters: ")))
	    (setq pt (getpoint "\nSpecify start point: "))
	    )
	(progn
	    (setq txthgt (* 0.02 (getvar 'viewsize))
		  circ
		     (entmakex
			 (list
			     '(0 . "CIRCLE")
			     (cons 8 (getdet (caadr dets) "Layer"))
			     (cons 10 pt)
			     (cons 40 (getdet (caadr dets) "Diameter"))
			     )
			 )
		  pl
		     (vlax-ename->vla-object
			 (entmakex
			     (list
				 '(0 . "LWPOLYLINE")
				 '(100 . "AcDbEntity")
				 '(100 . "AcDbPolyline")
				 (cons 6 (getdet (caadr dets) "Linetype"))
				 (cons 48 (getdet (caadr dets) "Linetype Scale"))
				 '(90 . 2)
				 '(70 . 0)
				 (cons 43 (getdet (caadr dets) "Line Width"))
				 (cons 8 (getdet (caadr dets) "Layer"))
				 (cons 10 pt)
				 (cons 40 (getdet (caadr dets) "Line Width"))
				 (cons 41 (getdet (caadr dets) "Line Width"))
				 '(42 . 0.0)
				 '(91 . 0)
				 (cons 10 (polar pt 0 1))
				 (cons 40 (getdet (caadr dets) "Line Width"))
				 (cons 41 (getdet (caadr dets) "Line Width"))
				 '(42 . 0.0)
				 '(91 . 0)
				 )
			     )
			 )
		  arrpl (vlax-ename->vla-object
			    (entmakex
				(list
				    '(0 . "LWPOLYLINE")
				    '(100 . "AcDbEntity")
				    '(100 . "AcDbPolyline")
				    '(6 . "Continuous")
				    '(90 . 2)
				    '(70 . 0)
				    (cons 43 (getdet (caadr dets) "Line Width"))
				    (cons 8 (getdet (caadr dets) "Layer"))
				    (cons 10 pt)
				    (cons 40 (getdet (caadr dets) "Line Width"))
				    (cons 41 (getdet (caadr dets) "Line Width"))
				    '(42 . 0.0)
				    '(91 . 0)
				    (cons 10 (polar pt 0 1))
				    (cons 40 (getdet (caadr dets) "Line Width"))
				    (cons 41 (getdet (caadr dets) "Line Width"))
				    '(42 . 0.0)
				    '(91 . 0)
				    )
				)
			    )
		  sctxt (entmakex
			    (list
				'(0 . "TEXT")
				'(100 . "AcDbEntity")
				'(100 . "AcDbText")
				(cons 8 (getdet (caadr dets) "Layer"))
				(cons 10 pt)
				(cons 1 (strcat "Current scale - 1:" (itoa (caadr dets))))
				(cons 40 txthgt)
				'(50 . 0.0)
				(cons 7 (getdet (caadr dets) "Text Style"))
				)
			    )
		  txt (vla-AddText msp "x" (vlax-3d-point pt) 200)
		  pts (vlax-get pl 'Coordinates)
		  coords (list (car pts) (cadr pts))
		  lastpt (list (caddr pts) (cadddr pts))
		  05pi (* 0.5 pi)
		  15pi (* 1.5 pi)
		  45deg (DegToRad 45)
		  135deg (DegToRad 135)
		  225deg (DegToRad 225)
		  sindx 1
		  curdets (nth sindx dets)
		  lim (1- (length dets))
		  activepolar (if (= (logand 8 (getvar 'autosnap)) 8) T)
		  msg "\nSpecify next point \n[+] to increase scale, [-] to reduce scale, [Space] or [Enter] to end at mouse distance"
		  )
	    (vla-put-Alignment txt acAlignmentMiddle)
	    (vla-put-StyleName txt (getdet (caadr dets) "Text Style"))
	    (princ msg)
	    (while
		(progn
		    (setq gr (grread t 15 0)
			  grp (last gr)
			  grv (car gr)
			  )
		    (cond
			((= grv 5)
			 (redraw)
			 (setq txthgt (* 0.02 (getvar 'viewsize)))
			 (entmod
			     (JH:SubstThrough
				 (list
				     (cons 10 (polar grp 45deg txthgt))
				     (cons 40 txthgt)
				     )
				 '(lambda (x) (vl-position (car x) '(10 40)))
				 (entget sctxt)
				 )
			     )
			 (setq grp (JH:grpolar (list (cadr (reverse coords)) (last coords) 0.0) grp 0.01 acGreen acYellow)
			       grplpt (list (car grp) (cadr grp))
			       angpl (angle lastpt grp)
			       )
			 (vlax-put pl 'Coordinates (append coords grplpt))
			 (if (> (setq maxlen (vla-get-Length pl)) dist)
			     (progn
				 (setq maxpt (vlax-curve-getPointAtDist pl dist))
				 (vlax-put pl 'Coordinates (append coords (list (car maxpt) (cadr maxpt))))
				 )
			     )
			 (setq endpt (vlax-curve-getEndPoint pl))
			 (vlax-put arrpl 'Coordinates
				   (apply 'append
					  (mapcar
					      '(lambda (x)
						   (list (car x) (cadr x))
						   )
					      (list
						  (polar endpt (+ angpl 135deg) arrowhead_size)
						  endpt
						  (polar endpt (+ angpl 225deg) arrowhead_size)
						  )
					      )
					  )
				   )
			 (vla-put-TextString txt (strcat (rtos (cvunit (vla-get-Length pl) "mm" (car units)) 2 1) (car units)))
			 (vla-put-TextAlignmentPoint txt
			     (vlax-3d-point
				 (polar
				     (midpt lastpt endpt)
				     (+ 05pi angpl)
				     200
				     )
				 )
			     )
			 (vla-put-Rotation txt (+ angpl (if (<= 05pi angpl 15pi) pi 0)))
			 T
			 )
			((= grv 2)
			 (cond
			     ((vl-position grp '(13 32)) nil)	; <--- Enter or Space is pressed
			     ((vl-position grp '(43 61))	; <-- + or = is pressed
			      (if (= sindx lim) (princ "\nNo larger scale found")
				  (progn
				      (setq sindx (1+ sindx) curdets (nth sindx dets) lay (cons 8 (getdet (car curdets) "Layer")))
				      (entmod
					  (JH:SubstThrough
					      (list lay (cons 40 (getdet (car curdets) "Diameter")))
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget circ)
					      )
					  )
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 6 (getdet (car curdets) "Linetype"))
						  (cons 48 (getdet (car curdets) "Linetype Scale"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 6 48)))
					      (entget (vlax-vla-object->ename pl))
					      )
					  )
				      (entmod (JH:SubstThrough (list lay) '(lambda (x) (= (car x) 8)) (entget (vlax-vla-object->ename arrpl))))
				      (vla-put-ConstantWidth pl (getdet (car curdets) "Line Width"))
				      (vla-put-ConstantWidth arrpl (getdet (car curdets) "Line Width"))
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 40 (getdet (car curdets) "Text Height"))
						  (cons 7 (getdet (car curdets) "Text Style"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget (vlax-vla-object->ename txt))
					      )
					  )
				      (entmod
					  (subst
					      (cons 1 (strcat "Current scale - 1:" (itoa (car curdets))))
					      (assoc 1 (entget sctxt))
					      (entget sctxt)
					      )
					  )
				      )
				  )
			      (princ msg)
			      )
			     ((= grp 45)	; <--- - is pressed
			      (if (= sindx 1) (princ "\nNo smaller scale found")
				  (progn
				      (setq sindx (1- sindx) curdets (nth sindx dets) lay (cons 8 (getdet (car curdets) "Layer")))
				      (entmod
					  (JH:SubstThrough
					      (list lay (cons 40 (getdet (car curdets) "Diameter")))
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget circ)
					      )
					  )
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 6 (getdet (car curdets) "Linetype"))
						  (cons 48 (getdet (car curdets) "Linetype Scale"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 6 48)))
					      (entget (vlax-vla-object->ename pl))
					      )
					  )
				      (entmod (JH:SubstThrough (list lay) '(lambda (x) (= (car x) 8)) (entget (vlax-vla-object->ename arrpl))))
				      (vla-put-ConstantWidth pl (getdet (car curdets) "Line Width"))
				      (vla-put-ConstantWidth arrpl (getdet (car curdets) "Line Width"))
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 40 (getdet (car curdets) "Text Height"))
						  (cons 7 (getdet (car curdets) "Text Style"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget (vlax-vla-object->ename txt))
					      )
					  )
				      (entmod
					  (subst
					      (cons 1 (strcat "Current scale - 1:" (itoa (car curdets))))
					      (assoc 1 (entget sctxt))
					      (entget sctxt)
					      )
					  )
				      )
				  )
			      (princ msg)
			      )
			     ((= grp 21)	; F10 is pressed (polar tracking)
			      (if activepolar
				  (progn (setq activepolar nil) (setvar 'autosnap (- (getvar 'autosnap) 8)))
				  (progn (setq activepolar T) (setvar 'autosnap (+ (getvar 'autosnap) 8)))
				  )
			      T
			      )
			     ((vl-position grp '(84 116))	; T is pressed
			      (setq units (append (cdr units) (list (car units))))
			      )
			     (T)
			     )
			 )
			((= grv 3)
			 (setq coords (append coords grplpt)
			       lastpt grplpt
			       )
			 (< maxlen dist)
			 )
			(T)
			)
		    )
		)
	    (redraw)
	    (entdel sctxt)
	    )
	)

    (if activeundo nil (vla-EndUndoMark adoc))
    (princ)
    )


;; JH:SubstThrough --> Jonathan Handojo
;; Substitutes all items in a list that passes the predicate function for
;; every item in a second list. If the second list runs out, returns the
;; substituted list followed with the remainder of the original list.
;;
;; itmlist - list containing substitution items
;; func - function that accepts one argument representing each element
;;        in the list to be evaluated
;; lst - list to evaluate and substitute
;;
;; Example call:
;; _$ (JH:SubstThrough '("A" "B" "C" "D") '(lambda (x) (or (<= 3 x 4) (>= x 7))) '(0 1 2 3 4 5 6 7 8 9 10))
;; (0 1 2 "A" "B" 5 6 "C" "D" 9 10)

(defun JH:SubstThrough (itmlst func lst)
    (setq itmlst (cons nil itmlst))
    (mapcar
	'(lambda (arg)
	     (if (and (cdr itmlst) ((eval func) arg))
		 (car (setq itmlst (cdr itmlst)))
		 arg
		 )
	     )
	lst
	)
    )

;; JH:grpolar --> Jonathan Handojo
;; Constructs a polar vector and the cross denoting the snap point to the polar
;; Returns either the snapped point to the polar tracking if found or the supplied
;; relative point if failed.
;; -------------------------
;; bpt - base point
;; ppt - relative point
;; pix - snap distance ratio (value as (/ <actual_length_on_screen> (getvar 'viewsize)))... 0.01 is a nice value. 
;; coltrack - color of the polar tracking line (ACI index)
;; colsnap - color of the cross formed by the snap (ACI index)
;; -------------------------
;; Only to work in WCS.

(defun JH:grpolar (bpt ppt pix coltrack colsnap / 45rad 90rad ang dis s snaps)
    (setq ang (getvar 'polarang)
	  90rad (* 0.5 pi)
	  45rad (* (/ pi 180) 45)
	  dis (* 1.15 pix (getvar 'viewsize))
	  s (- ang))
    (repeat (fix (/ (* 2 pi) ang))
	(setq snaps (cons (setq s (+ ang s)) snaps))
	)
    (if (= 8 (logand 8 (getvar 'autosnap)))
	(cond
	    (
	     (vl-some
		 '(lambda (x / catch)
		      (if
			  (equal
			      ppt
			      (setq catch (inters bpt (polar bpt x 100) ppt (polar ppt (+ 90rad x) 100) nil))
			      dis
			      )
			  (progn
			      (grvecs
				  (list coltrack bpt (polar bpt (angle bpt catch) (* 10 (getvar 'viewsize)))
					colsnap (polar catch 45rad dis) (polar catch (+ 45rad pi) dis)
					colsnap (polar catch (+ 45rad 90rad) dis) (polar catch (+ 45rad 90rad 90rad 90rad) dis)
					)
				  '((1.0 0.0 0.0 0.0)
				    (0.0 1.0 0.0 0.0)
				    (0.0 0.0 1.0 0.0)
				    (0.0 0.0 0.0 1.0))
				  )
			      catch
			      )
			  )
		      )
		 snaps
		 )
	     )
	    (ppt)
	    )
	ppt
	)
    )

I've never actually posted something this long before to CADTutor, hopefully it's of some use to you and others who might need it. Unfortunately it would work only in WCS. (Not tested on UCS, but I'm pretty sure it will fail in terms of the GrPolar. Unless someone wants to refine it, but that's to the best of my abilities already.

 

 

Hi @Jonathan Handojo, thank you so much for your time and help on this. The arrowhead now is close-ended, probably because you have changed it to continuous linetype. Yes polar tracking is enough . I managed to edit the lts, text height and line width to suit my needs. However there are a few things that I'll need help with:

 

For 50 scale - I've tried changed the text ht to 100 but it still display as 200, not sure why; - Need to reduce the arrowhead size keeping line width.

For 300 scale - after increasing the text ht it now overlaps with polyline, need to move text up; - Need to increase the arrowhead size while keeping the line width.

For all scales - Currently the circle is using 'current linetype', need to change to continuous linetype.

 

I noticed when I toggle to 300 scale and toggle back to 100 or 50 scale the polyline lts will stuck at that used for 300 scale, not sure why. I've attached the above cad file and my edited lisp for your reference.

 

Lastly, for large scale project on one floor plan I'll need to run this polyline many times with the same scale and distance. Which means need to re-key in the same distance and toggle to the same scale each and every time I run the command. To avoid this is there a way for the command to remember my last used scale and distance and start with them as default in the subsequent use of the command?

 

Any help on the above is very much appreciated.   Thank you!

 

Polyline with Defined Distance 2.dwg Polyline Max Length_TracePoly2.lsp

[Jonathan Handojo]

There's a bug when setting the scale to 1.0 which I've never noticed. That's now amended for in this version.

 

As you requested, this version will remember all your inputs after the very first time completing this command. I've also added a new column "Arrowhead Length" for precautions.

 

Btw, pressing T will switch the units between "mm", "cm", and "m".

 

For some reason, idk why the polar tracking is acting weird in your dwg, but it was fine for mine at least when starting a new blank drawing.

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                                              ;;;
;;;  Tracepoly Instructions                                                                      ;;;
;;;                                                                                              ;;;
;;;  Default values and scales can be set up below. Find "TRACEPOLY SETUP" and specify defaults  ;;;
;;;  as necessary.                                                                               ;;;
;;;                                                                                              ;;;
;;;  When tracing the polyline,                                                                  ;;;
;;;                                                                                              ;;;
;;;  [+] to increase scale in the setup                                                          ;;;
;;;  [-] to decrease scale in the setup                                                          ;;;
;;;  [T] to toggle between measurement units                                                     ;;;
;;;  [Space] or [Enter] to accept polyline at the location of the mouse cursor (unless it        ;;;
;;;  reached the limit)                                                                          ;;;
;;;  [F10] to toggle Polar Tracking mode. Angle can be altered while tracing the polyline.       ;;;
;;;                                                                                              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:tracepoly
       
       (/ *error*   05pi      135deg	15pi	  225deg    45deg     acadobj	activepolar
	  activeundo	      adoc	angpl	  arrdis    arrowhead_size	arrpl	  circ
	  coords    crosscolor		curdets	  def	    defdist   defs	defscale  degtorad
	  dets	    dist      endpt	getdet	  gr	    grp	      grplpt	grv	  lastpt
	  lay	    lim	      lwid	maxlen	  maxpt	    midpt     msg	msp	  pl
	  pt	    pts	      scl	sctxt	  sindx	    thgt      trackcolor	  txt
	  txthgt    units     unloop	x)

    (defun *error* ( msg )
	(if (eq (type sctxt) 'ename) (entdel sctxt))
	(vla-EndUndoMark adoc)
	(if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*"))
	    (princ (strcat "Error: " msg))
	    )
	)
    (defun midpt (p1 p2) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))   ; <--- Not applicable for 3D space
    (defun DegToRad (ang) (* (/ pi 180) ang))
    (defun getdet (scale tag / catch)
	(setq catch (nth (vl-position tag (car dets)) (assoc scale dets)))
	(cond
	    ((= tag "Diameter") (/ (float catch) 2))
	    ((= tag "Linetype")
	     (if (null (tblsearch "ltype" catch)) "Continuous" catch)
	     )
	    ((= tag "Layer")
	     (if
		 (or
		     (null catch)
		     (null (tblsearch "layer" catch))
		     (null (zerop (cdr (assoc 70 (tblsearch "layer" catch)))))
		     (minusp (cdr (assoc 62 (tblsearch "layer" catch))))
		     )
		 (getvar 'clayer)
		 catch
		 )
	     )
	    ((= tag "Text Style")
	     (if (null (tblsearch "style" catch)) "Standard" catch)
	     )
	    (catch)
	    )
	)
    (setq acadobj (vlax-get-acad-object)
	  adoc (vla-get-ActiveDocument acadobj)
	  msp (vla-get-ModelSpace adoc)
	  activeundo nil)
    (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T))

    ;;; ------------------------------------- TRACEPOLY SETUP ------------------------------------- ;;;
    
    (setq
	trackcolor acGreen  ; <--- Polar AutoTrack color
	crosscolor acYellow ; <--- Polar Snap color 
	dets
	   '(
	     ( ;|1.|; "Scale" ;|2.|; "Linetype" ;|3.|; "Line Width" ;|4.|; "Linetype Scale" ;|5.|; "Layer" ;|6.|; "Diameter" ;|7|; "Text Style" ;|8.|; "Text Height" ;|9.|; "Arrowhead Length")
	     
	     ; DO NOT DELETE OR CHANGE THE ABOVE (Except maybe for the inner comment)
	     ; If linetype (2) does not exist, "Continuous" will be used
	     ; If layer supplied (5) is nil or is in a locked, off, or frozen layer, current layer will be used
	     ; If text style (7) does not exist, "Standard" will be used
	     ; Add more list below if you want to use more scales. Feel free to modify as well if it's not according to your taste
	     
	     (50 "DASHED2" 20 0.2 nil 100 "Arial" 100 125)
	     (100 "DASHED2" 50 0.4 nil 200 "Arial" 200 250)
	     (300 "DASHED2" 100 1.0 nil 400 "Arial" 600 750)
	     )
	units '("mm" "cm" "m")
	)

    ;;; ------------------------------------- TRACEPOLY SETUP ------------------------------------- ;;;

    (if (setq defs (getenv "Jonathan Handojo\\TracePoly"))
	(progn
	    (setq defs (read defs)
		  defdist (car defs)
		  defscale (cadr defs)
		  )
	    (if
		(null
		    (setq defscale
			     (vl-some
				 '(lambda (x)
				      (if (equal (car x) defscale 1e-8)
					  (car x)
					  )
				      )
				 dets
				 )
			  )
		    )
		(setq defscale (caadr defs))
		)

	    (if (vl-position (setq unloop (strcase (vl-princ-to-string (last defs)) T)) units)
		(while (not (equal unloop (car units)))
		    (setq units (append (cdr units) (list (car units))))
		    )
		)
	    )
	(setq defscale (caadr dets))
	)
    (if
	(and
	    (null (and (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer)))))) (null (alert "\nPlease unlock the current layer before proceeding"))))
	    (setq dist
		     (cond
			 ((progn (initget 6) (getdist (strcat "\nSpecify maximum distance in millimeters " (if defdist (strcat "<" (rtos defdist 2 1) ">") "") ": "))))
			 (defdist)
			 )
		  )
	    (setq pt (getpoint "\nSpecify start point: "))
	    )
	(progn
	    (setq txthgt (* 0.02 (getvar 'viewsize))
		  circ
		     (entmakex
			 (list
			     '(0 . "CIRCLE")
			     (cons 8 (getdet defscale "Layer"))
			     '(6 . "Continuous")
			     (cons 10 pt)
			     (cons 40 (getdet defscale "Diameter"))
			     )
			 )
		  pl
		     (vlax-ename->vla-object
			 (entmakex
			     (list
				 '(0 . "LWPOLYLINE")
				 '(100 . "AcDbEntity")
				 '(100 . "AcDbPolyline")
				 (cons 6 (getdet defscale "Linetype"))
				 (cons 48 (getdet defscale "Linetype Scale"))
				 '(90 . 2)
				 '(70 . 0)
				 (cons 43 (getdet defscale "Line Width"))
				 (cons 8 (getdet defscale "Layer"))
				 (cons 10 pt)
				 (cons 40 (getdet defscale "Line Width"))
				 (cons 41 (getdet defscale "Line Width"))
				 '(42 . 0.0)
				 '(91 . 0)
				 (cons 10 (polar pt 0 1))
				 (cons 40 (getdet defscale "Line Width"))
				 (cons 41 (getdet defscale "Line Width"))
				 '(42 . 0.0)
				 '(91 . 0)
				 )
			     )
			 )
		  arrpl (vlax-ename->vla-object
			    (entmakex
				(list
				    '(0 . "LWPOLYLINE")
				    '(100 . "AcDbEntity")
				    '(100 . "AcDbPolyline")
				    '(6 . "Continuous")
				    '(90 . 2)
				    '(70 . 0)
				    (cons 43 (getdet defscale "Line Width"))
				    (cons 8 (getdet defscale "Layer"))
				    (cons 10 pt)
				    (cons 40 (getdet defscale "Line Width"))
				    (cons 41 (getdet defscale "Line Width"))
				    '(42 . 0.0)
				    '(91 . 0)
				    (cons 10 (polar pt 0 1))
				    (cons 40 (getdet defscale "Line Width"))
				    (cons 41 (getdet defscale "Line Width"))
				    '(42 . 0.0)
				    '(91 . 0)
				    )
				)
			    )
		  sctxt (entmakex
			    (list
				'(0 . "TEXT")
				'(100 . "AcDbEntity")
				'(100 . "AcDbText")
				(cons 8 (getdet defscale "Layer"))
				(cons 10 pt)
				(cons 1 (strcat "Current scale - 1:" (vl-princ-to-string defscale)))
				(cons 40 txthgt)
				'(50 . 0.0)
				(cons 7 (getdet defscale "Text Style"))
				)
			    )
		  txt (vla-AddText msp "x" (vlax-3d-point pt) (getdet defscale "Text Height"))
		  pts (vlax-get pl 'Coordinates)
		  coords (list (car pts) (cadr pts))
		  lastpt (list (caddr pts) (cadddr pts))
		  05pi (* 0.5 pi)
		  15pi (* 1.5 pi)
		  45deg (DegToRad 45)
		  135deg (DegToRad 135)
		  225deg (DegToRad 225)
		  sindx (vl-position defscale (mapcar 'car dets))
		  curdets (nth sindx dets)
		  lim (1- (length dets))
		  activepolar (if (= (logand 8 (getvar 'autosnap)) 8) T)
		  lwid (getdet defscale "Line Width")
		  thgt (getdet defscale "Text Height")
		  arrdis (/ (getdet defscale "Arrowhead Length") 2)
		  msg "\nSpecify next point \n[+] to increase scale, [-] to reduce scale, [Space] or [Enter] to end at mouse distance"
		  )
	    (vla-put-Alignment txt acAlignmentMiddle)
	    (vla-put-StyleName txt (getdet defscale "Text Style"))
	    (princ msg)
	    (while
		(progn
		    (setq gr (grread t 15 0)
			  grp (last gr)
			  grv (car gr)
			  )
		    (cond
			((= grv 5)
			 (redraw)
			 (setq txthgt (* 0.02 (getvar 'viewsize)))
			 (entmod
			     (JH:SubstThrough
				 (list
				     (cons 10 (polar grp 45deg txthgt))
				     (cons 40 txthgt)
				     )
				 '(lambda (x) (vl-position (car x) '(10 40)))
				 (entget sctxt)
				 )
			     )
			 (setq grp (JH:grpolar (list (cadr (reverse coords)) (last coords) 0.0) grp 0.01 acGreen acYellow)
			       grplpt (list (car grp) (cadr grp))
			       angpl (angle lastpt grp)
			       )
			 (vlax-put pl 'Coordinates (append coords grplpt))
			 (if (> (setq maxlen (vla-get-Length pl)) dist)
			     (progn
				 (setq maxpt (vlax-curve-getPointAtDist pl dist))
				 (vlax-put pl 'Coordinates (append coords (list (car maxpt) (cadr maxpt))))
				 )
			     )
			 (setq endpt (vlax-curve-getEndPoint pl))
			 (vlax-put arrpl 'Coordinates
				   (apply 'append
					  (mapcar
					      '(lambda (x)
						   (list (car x) (cadr x))
						   )
					      (list
						  (polar endpt (+ angpl 135deg) arrdis)
						  endpt
						  (polar endpt (+ angpl 225deg) arrdis)
						  )
					      )
					  )
				   )
			 (vla-put-TextString txt (strcat (rtos (cvunit (vla-get-Length pl) "mm" (car units)) 2 1) (car units)))
			 (vla-put-TextAlignmentPoint txt
			     (vlax-3d-point
				 (polar
				     (midpt lastpt endpt)
				     (+ 05pi angpl)
				     (+ (/ lwid 2.0) thgt)
				     )
				 )
			     )
			 (vla-put-Rotation txt (+ angpl (if (<= 05pi angpl 15pi) pi 0)))
			 T
			 )
			((= grv 2)
			 (cond
			     ((vl-position grp '(13 32)) nil)	; <--- Enter or Space is pressed
			     ((vl-position grp '(43 61))	; <-- + or = is pressed
			      (if (= sindx lim) (princ "\nNo larger scale found")
				  (progn
				      (setq sindx (1+ sindx)
					    curdets (nth sindx dets)
					    lay (cons 8 (getdet (car curdets) "Layer"))
					    lwid (getdet (car curdets) "Line Width")
					    thgt (getdet (car curdets) "Text Height")
					    arrdis (/ (getdet (car curdets) "Arrowhead Length") 2)
					    )
				      (entmod
					  (JH:SubstThrough
					      (list lay (cons 40 (getdet (car curdets) "Diameter")))
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget circ)
					      )
					  )
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 6 (getdet (car curdets) "Linetype"))
						  (cons 48 (getdet (car curdets) "Linetype Scale"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 6 48)))
					      (if (null (assoc 48 (setq scl (entget (vlax-vla-object->ename pl)))))
						  (append scl '((48 . 1.0)))
						  scl
						  )
					      )
					  )
				      (entmod (JH:SubstThrough (list lay) '(lambda (x) (= (car x) 8)) (entget (vlax-vla-object->ename arrpl))))
				      (vla-put-ConstantWidth pl (getdet (car curdets) "Line Width"))
				      (vla-put-ConstantWidth arrpl (getdet (car curdets) "Line Width"))
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 40 (getdet (car curdets) "Text Height"))
						  (cons 7 (getdet (car curdets) "Text Style"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget (vlax-vla-object->ename txt))
					      )
					  )
				      (entmod
					  (subst
					      (cons 1 (strcat "Current scale - 1:" (itoa (car curdets))))
					      (assoc 1 (entget sctxt))
					      (entget sctxt)
					      )
					  )
				      )
				  )
			      (princ msg)
			      )
			     ((= grp 45)	; <--- - is pressed
			      (if (= sindx 1) (princ "\nNo smaller scale found")
				  (progn
				      (setq sindx (1- sindx)
					    curdets (nth sindx dets)
					    lay (cons 8 (getdet (car curdets) "Layer"))
					    lwid (getdet (car curdets) "Line Width")
					    thgt (getdet (car curdets) "Text Height")
					    arrdis (/ (getdet (car curdets) "Arrowhead Length") 2)
					    )
				      (entmod
					  (JH:SubstThrough
					      (list lay (cons 40 (getdet (car curdets) "Diameter")))
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget circ)
					      )
					  )
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 6 (getdet (car curdets) "Linetype"))
						  (cons 48 (getdet (car curdets) "Linetype Scale"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 6 48)))
					      (if (null (assoc 48 (setq scl (entget (vlax-vla-object->ename pl)))))
						  (append scl '((48 . 1.0)))
						  scl
						  )
					      )
					  )
				      (entmod (JH:SubstThrough (list lay) '(lambda (x) (= (car x) 8)) (entget (vlax-vla-object->ename arrpl))))
				      (vla-put-ConstantWidth pl (getdet (car curdets) "Line Width"))
				      (vla-put-ConstantWidth arrpl (getdet (car curdets) "Line Width"))
				      (entmod
					  (JH:SubstThrough
					      (list
						  lay
						  (cons 40 (getdet (car curdets) "Text Height"))
						  (cons 7 (getdet (car curdets) "Text Style"))
						  )
					      '(lambda (x) (vl-position (car x) '(8 40)))
					      (entget (vlax-vla-object->ename txt))
					      )
					  )
				      (entmod
					  (subst
					      (cons 1 (strcat "Current scale - 1:" (itoa (car curdets))))
					      (assoc 1 (entget sctxt))
					      (entget sctxt)
					      )
					  )
				      )
				  )
			      (princ msg)
			      )
			     ((= grp 21)	; F10 is pressed (polar tracking)
			      (if activepolar
				  (progn (setq activepolar nil) (setvar 'autosnap (- (getvar 'autosnap) 8)))
				  (progn (setq activepolar T) (setvar 'autosnap (+ (getvar 'autosnap) 8)))
				  )
			      T
			      )
			     ((vl-position grp '(84 116))	; T is pressed
			      (setq units (append (cdr units) (list (car units))))
			      )
			     (T)
			     )
			 )
			((= grv 3)
			 (setq coords (append coords grplpt)
			       lastpt grplpt
			       )
			 (< maxlen dist)
			 )
			(T)
			)
		    )
		)
	    (redraw)
	    (entdel sctxt)
	    (setenv "Jonathan Handojo\\TracePoly" (strcat "(" (rtos dist 2 1) " " (rtos (car curdets)) " " (car units) ")"))
	    )
	)

    (if activeundo nil (vla-EndUndoMark adoc))
    (princ)
    )


;; JH:SubstThrough --> Jonathan Handojo
;; Substitutes all items in a list that passes the predicate function for
;; every item in a second list. If the second list runs out, returns the
;; substituted list followed with the remainder of the original list.
;;
;; itmlist - list containing substitution items
;; func - function that accepts one argument representing each element
;;        in the list to be evaluated
;; lst - list to evaluate and substitute
;;
;; Example call:
;; _$ (JH:SubstThrough '("A" "B" "C" "D") '(lambda (x) (or (<= 3 x 4) (>= x 7))) '(0 1 2 3 4 5 6 7 8 9 10))
;; (0 1 2 "A" "B" 5 6 "C" "D" 9 10)

(defun JH:SubstThrough (itmlst func lst)
    (setq itmlst (cons nil itmlst))
    (mapcar
	'(lambda (arg)
	     (if (and (cdr itmlst) ((eval func) arg))
		 (car (setq itmlst (cdr itmlst)))
		 arg
		 )
	     )
	lst
	)
    )

;; JH:grpolar --> Jonathan Handojo
;; Constructs a polar vector and the cross denoting the snap point to the polar
;; Returns either the snapped point to the polar tracking if found or the supplied
;; relative point if failed.
;; -------------------------
;; bpt - base point
;; ppt - relative point
;; pix - snap distance ratio (value as (/ <actual_length_on_screen> (getvar 'viewsize)))... 0.01 is a nice value. 
;; coltrack - color of the polar tracking line (ACI index)
;; colsnap - color of the cross formed by the snap (ACI index)
;; -------------------------
;; Only to work in WCS.

(defun JH:grpolar (bpt ppt pix coltrack colsnap / 45rad 90rad ang dis s snaps)
    (setq ang (getvar 'polarang)
	  90rad (* 0.5 pi)
	  45rad (* (/ pi 180) 45)
	  dis (* 1.15 pix (getvar 'viewsize))
	  s (- ang))
    (repeat (fix (/ (* 2 pi) ang))
	(setq snaps (cons (setq s (+ ang s)) snaps))
	)
    (if (= 8 (logand 8 (getvar 'autosnap)))
	(cond
	    (
	     (vl-some
		 '(lambda (x / catch)
		      (if
			  (equal
			      ppt
			      (setq catch (inters bpt (polar bpt x 100) ppt (polar ppt (+ 90rad x) 100) nil))
			      dis
			      )
			  (progn
			      (grvecs
				  (list coltrack bpt (polar bpt (angle bpt catch) (* 10 (getvar 'viewsize)))
					colsnap (polar catch 45rad dis) (polar catch (+ 45rad pi) dis)
					colsnap (polar catch (+ 45rad 90rad) dis) (polar catch (+ 45rad 90rad 90rad 90rad) dis)
					)
				  '((1.0 0.0 0.0 0.0)
				    (0.0 1.0 0.0 0.0)
				    (0.0 0.0 1.0 0.0)
				    (0.0 0.0 0.0 1.0))
				  )
			      catch
			      )
			  )
		      )
		 snaps
		 )
	     )
	    (ppt)
	    )
	ppt
	)
    )

 

[JCYK]

On 5/7/2020 at 10:42 PM, Jonathan Handojo said:

There's a bug when setting the scale to 1.0 which I've never noticed. That's now amended for in this version.

 

As you requested, this version will remember all your inputs after the very first time completing this command. I've also added a new column "Arrowhead Length" for precautions.

 

Btw, pressing T will switch the units between "mm", "cm", and "m".

 

For some reason, idk why the polar tracking is acting weird in your dwg, but it was fine for mine at least when starting a new blank drawing.

 

Hi @Jonathan Handojo, no words can express how grateful I am to you!  You have created this awesome lisp that has met all my needs and even beyond. I am sure this lisp can benefit countless people! Once again a big THANK YOU!  

[JCYK]

On 5/7/2020 at 6:10 PM, dlanorh said:

 

Thank you. I can't think of anyway to develop it further at present, although suggestions are always welcome. It was originally designed to calculate delivery route distances for heavy equipment (safes, ATM's etc) across wooden suspended floors/basement area and allowed the operator to dynamically extract distances for the insertion of photographs denoting problems and the positioning of spreader plates etc.

 

Hi @dlanorh, thank you very much for your help as well! These lisps that we have can be very useful in many different nature that deals with distance.

[JCYK]

Hi lisp experts, I have a wild idea for the above lisp, not sure if it is possible. 

 

The above lisp helps one to draw polyline with specified max. length and displays numeric text representing the length of the polyline. Is it possible for the length text to be permanently linked to the polyline (unless someone explode it) such that when one adjusts the polyline vertex which will change the length (but still has a cap to the original specified max. length) the length text displayed will be updated accordingly? 

 

Thank you!!

[BIGAL]

Yes very easy home work for you, if you use a field in say mtext an option is "Length" so change the pline using say grips and the length will update after a regen.

 

So google field and pline length.

 

(vla-put-TextString txt (strcat (rtos (cvunit (vla-get-Length pl) "mm" (car units)) 2 1) (car units)))

Edited May 17, 2020 by BIGAL

[JCYK]

Hi BIGAL, thank you for responding! Do forgive me for not able to grasp your instruction as I'm not versed in lisp coding  To incorporate the above into the lisp is really beyond my capabilities, unless it's a really very easy type that a layman can do. 

 

Would be very thankful if anyone can help me incorporate this function into the lisp.

 

Thank you.