Leaderboard

If you want to include it in your grread code, (setq var (grread...) returns (x y) to var on an event. If x = 2 it is a keyboard input and y is the ascii value of the key pressed (so for + key this would be (2 43)

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 ) )

For me at least, I don't think the goal is to deliver solutions to members other than negotiating and learning and sharing smart ideas as best as possible from each other in such threads when professional members contribute in, so keeping threads academic and a good reference for visitors must be considered a smart conduct as well.