JCYK Posted May 3, 2020 Share Posted May 3, 2020 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 Quote Link to comment Share on other sites More sharing options...
Jonathan Handojo Posted May 3, 2020 Share Posted May 3, 2020 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? Quote Link to comment Share on other sites More sharing options...
dlanorh Posted May 3, 2020 Share Posted May 3, 2020 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 Quote Link to comment Share on other sites More sharing options...
Jonathan Handojo Posted May 3, 2020 Share Posted May 3, 2020 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) ) 1 Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted May 3, 2020 Share Posted May 3, 2020 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. Quote Link to comment Share on other sites More sharing options...
JCYK Posted May 5, 2020 Author Share Posted May 5, 2020 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! Quote Link to comment Share on other sites More sharing options...
CAD_Noob Posted May 5, 2020 Share Posted May 5, 2020 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 . Quote Link to comment Share on other sites More sharing options...
JCYK Posted May 5, 2020 Author Share Posted May 5, 2020 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. Quote Link to comment Share on other sites More sharing options...
dlanorh Posted May 5, 2020 Share Posted May 5, 2020 Attached working version if you're interested. Arial textstyle must be defined. Will work in imperial or metric. dynlenlwp2.lsp Quote Link to comment Share on other sites More sharing options...
Jonathan Handojo Posted May 5, 2020 Share Posted May 5, 2020 (edited) 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 Quote Link to comment Share on other sites More sharing options...
dlanorh Posted May 5, 2020 Share Posted May 5, 2020 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 Quote Link to comment Share on other sites More sharing options...
JCYK Posted May 7, 2020 Author Share Posted May 7, 2020 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! Quote Link to comment Share on other sites More sharing options...
dlanorh Posted May 7, 2020 Share Posted May 7, 2020 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. Quote Link to comment Share on other sites More sharing options...
JCYK Posted May 7, 2020 Author Share Posted May 7, 2020 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 Quote Link to comment Share on other sites More sharing options...
Jonathan Handojo Posted May 7, 2020 Share Posted May 7, 2020 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 ) ) 1 Quote Link to comment Share on other sites More sharing options...
JCYK Posted May 9, 2020 Author Share Posted May 9, 2020 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! Quote Link to comment Share on other sites More sharing options...
JCYK Posted May 9, 2020 Author Share Posted May 9, 2020 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. Quote Link to comment Share on other sites More sharing options...
JCYK Posted May 15, 2020 Author Share Posted May 15, 2020 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!! Quote Link to comment Share on other sites More sharing options...
BIGAL Posted May 17, 2020 Share Posted May 17, 2020 (edited) 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 Quote Link to comment Share on other sites More sharing options...
JCYK Posted May 18, 2020 Author Share Posted May 18, 2020 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. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.