Leaderboard

Or just call MULTIPLE before calling APV.

Another way. this doesn't repeat but uses ldata so the user can just hit enter if they aren't changing the offset from last value inputted. Has to have an existing polyline to run and the new end point. will only update the last two closest points of the old polyline to the new end point. Route.mp4 Route.lsp

Since Lee's Code only has you picking a point its easy enough. Just add a call at the end of APV (line 95) to call itself again. This will force a loop that you have to hit esc to exit. - Edit This is a better option. Has undo marks. You could also set your snaps before entering the command if you want to. ;;----------------------------------------------------------------------------;; ;; Add Polyline Vertex loop ;; Dependent AddLWPolylineVertexV1-1.lsp (defun C:APVL ( / ) (vl-load-com) (princ "\nStarting Add Polyline Vertex loop. Press ESC to stop.") (vla-StartUndoMark (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object)))) ;(setvar 'OSMODE 3) ;End and mid point snaps (while T (C:APV) ) (princ "\nAdd Polyline Vertex Loop ended.") (vla-EndUndoMark doc) (princ) )

I think this is an extremely interesting problem that deserves significantly more lines of code than have been written so far in this thread. I believe those lines shouldn't be long in coming.

Anyway, the result obtained by Dexus's code is one of the best (perhaps the best) I've found on the web. Thanks for that, Dexus

Rather than explode the COGO point what are you trying to do ? I have for example write the RL of a cogo point as text next to the point. We used this as a quick reference when designing, we would select only the points that we want to see the RL. It could be expanded to say label XYZ, PtXYZD etc. The tree block should be on the correct layer according to your Description key Sets. A side note it's possible to update a cogo point dynamic block, I have something that does just that, it looks at the description, so TR6*300, dynamic block has a trunk and spread 2 objects, running my lisp would get a 6m spread with a 300 mm trunk. @Steven P the COGO points in Civ3D are proxy objects. In a dwg if labels are off can not turn on in ACAD. I am looking at talking to Bricsys about getting at "AeccXUiLand.AeccApplication." when a civ3D dwg is opened in Bricscad. Getting at CIV3D objects via lisp can be easy or difficult.

Up load your LISP so we can have a look. I suspect you will want to explode the block and then use entlast select it ready to move it to the correct layer - that might be enough of a hint? Since you have the entity name, I would just use entmod to change the layer

Glad it works. Yes.

Hi thanks a lot. It works. how can i call multiple prior to calling APV? A friend of mine got me this vlx file but there is an annoying pop-up but it works as well addv.vlx

...Continue from previous post, experiment with imperial mod, quotient, division. ##********************************************************************************************** ## 45 UDF/ Excel name: impaMQD() - Similar Excel MOD() function with optional parmeters, ## return quotient or division [opt_1Quotient_or_2Division]. ## ## Note: This function uses todec() & toimpa() as sub-functions. ## ## Notes with optional parameters: ## ## [opt_1Quotient_or_2Division] = 1 , Similar Excel QUOTIENT() function - Returns the integer ## portion of a division ## [opt_1Quotient_or_2Division] = 2 , division calculation (varDividend/varDivisor) ## ## Optional parameters other than 1 & 2 will return error #N/A ## ## Rev. 1.0 - 9/2/2025 ##********************************************************************************************** =LAMBDA(varDividend,varDivisor,[opt_1Quotient_or_2Division], LET(optN,IF(ISOMITTED(opt_1Quotient_or_2Division),0, IF(AND(opt_1Quotient_or_2Division<=2,opt_1Quotient_or_2Division>0),opt_1Quotient_or_2Division,NA())), varD1,todec(varDividend), varD2,todec(varDivisor), answrM,varD1-(varD2*INT(varD1/varD2)), answrQ,ROUNDDOWN(varD1/varD2,0), answrD,varD1/varD2, SWITCH(TRUE, optN=0,IF(AND(ISNUMBER(varDividend),ISNUMBER(varDivisor)),answrM,IF(OR(AND(ISTEXT(varDividend),ISTEXT(varDivisor)),ISNUMBER(varDivisor)),toimpa(answrM),"Error!")), optN=1,IF(OR(AND(ISNUMBER(varDividend),ISNUMBER(varDivisor)),AND(ISTEXT(varDividend),ISTEXT(varDivisor))),answrQ,IF(ISNUMBER(varDivisor),toimpa(answrQ),"Error!")), optN=2,IF(OR(AND(ISNUMBER(varDividend),ISNUMBER(varDivisor)),AND(ISTEXT(varDividend),ISTEXT(varDivisor))),answrD,IF(ISNUMBER(varDivisor),toimpa(answrD),"Error!")), NA() ) ) )

You're missing the double backslash ("*\\P*") Also, note that the use of vl-string-subst with a constant starting position and wcmatch to test the content is dangerous in general as this will result in an infinite loop if the replacement string contains the find string, e.g. consider replacing "new" with "knew" - your code would loop indefinitely.

Hi everyone, I’ve been working on a project to automate the tedious process of room quantity takeoffs (Area & Perimeter) in AutoCAD. I know how time-consuming it can be to manually measure every room and transfer data to Excel, so I developed a Lisp plugin called Quantity Surveyor Pro. It's currently v1.0 and completely free for the community. Key Features: ☻Auto-Boundary Detection: Works like the 'Boundary' command but smarter. ☻Smart Tagging: Automatically places Room Name/No tags with area & perimeter. ☻Excel Export: Exports all data to a CSV/Excel file with one click. ☻Table Generation: Creates a summary table inside AutoCAD. I would really appreciate it if you could test it and give me some feedback on how to improve it further. You can download it here: https://cadlisp.com (It supports both English and Turkish languages) Thanks in advance for your support!

Per the documentation, (vl-string-translate) replaces by character, not by string. Hence, for the arguments you have specified, the backslash ("\\") will be replaced by the newline character ("\n") and the "P" does not have a replacement character. Instead, since you're looking to substitute one string for another, you should use the (vl-string-subst) function (in a loop so as to replace all occurrences). I have written a String Subst wrapper which you could call in the following way: (LM:stringsubst "\n" "\\P" "Abcdef\\Pghijk\\Plmnop")

You can build a lisp function in Python that will explode the MText into fragments @Ap.Command() def doit(): try: ps, id, pnt = Ed.Editor.entSel("\nSelect: ", Db.MText.desc()) mt = Db.MText(id) frags = mt.getFragments() val = "" for frag in frags: val += ' ' val += frag[Db.MTextFragmentType.kTextValue] print(frags) print(val) except Exception: print(traceback.format_exc()) [PyGe.Point3d(18.25565516926225,16.52816695203355,0.00000000000000), PyGe.Vector3d(0.00000000000000,0.00000000000000,1.00000000000000), PyGe.Vector3d(1.00000000000000,0.00000000000000,0.00000000000000), 'Hello', None, None, PyGe.Point2d(0.63669849931787,0.20327421555252), 0.2, 1.0, 0.0, 1.0, <PyDb.EntityColor object at 0x000001AD0C1D0F90>, 0, 0, 0, 0, 0, [PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000), PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000)], [PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000), PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000)], [PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000), PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000)], 'Arial', False, False] [PyGe.Point3d(19.29427328818596,15.86150028536689,0.00000000000000), PyGe.Vector3d(0.00000000000000,0.00000000000000,1.00000000000000), PyGe.Vector3d(1.00000000000000,0.00000000000000,0.00000000000000), 'World', None, None, PyGe.Point2d(0.72960436562074,0.20327421555252), 0.2, 1.0, 0.0, 1.0, <PyDb.EntityColor object at 0x000001AD0C1D1770>, 0, 0, 0, 0, 0, [PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000), PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000)], [PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000), PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000)], [PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000), PyGe.Point3d(0.00000000000000,0.00000000000000,0.00000000000000)], 'Arial', False, False] Hello World

Hi, How can I ensure that vlax-curve-getClosestPointToProjection returns the closest point in every case? I suspect that the curve is merging in the projected plane and therefore it does not always return the closest point in the desired direction. Alternatively, I could probably use vla-IntersectWith method with a line object and find the closest point, but I'm using grread where vlax-curve-getClosestPointToProjection will be more appropriate, I don't have to create and delete line objects in while loop. Animation.apng Drawing1.dwg sline2_dev_v2.lsp

I know this query is old, but... Maybe for the path to multiple locations use the Traveling Salesman Problem (TSP) algorithm. @marko_ribar has a LISP on CADTutor. Bellman-Ford algorithm can handle the shortest path from a single source to all other nodes might work.

I have one in C++ wrapped for lisp https://www.theswamp.org/index.php?topic=58049.msg613033#msg613033 I’d have to look at the code again, I forgot, I think I generated a tin, from the tin, create a graph of the triangle edges

Like that

Do you really need to disassociate the dimension? If you don't need to for another reason, you can delete that part of the code.

(defun c:DimAssOf ( / ss e le n) (vl-load-com) (prompt "\nSelect DIMENSION to disable associativity: ") (setq ss (ssget '((0 . "DIMENSION")))) (if ss (progn (command "_.DIMDISASSOCIATE" ss "") (prompt (strcat "\nDone: associativity is disabled for " (itoa (sslength ss)) " dimensions." ) ) (while (setq e (ssname ss (setq n (if n (1+ n) 0)))) (setq le (entget e)) (entmod (subst (list 14 (cadr (assoc 13 le)) (caddr (assoc 14 (entget e))) 0.0) (assoc 14 le) le)) ) ) ) (princ) )

I only did a quick peek since I am busy and haven't used SolidWorks in quite a while, but it looked like a pretty easy change. I am sure a deeper dig on the forums would show the process for updating, but I really didn't have time to look harder into it.

This is cut out of a CIV3D lisp for write text height of a cogo point. (alert "Pick CIV3D points press ESC or pick nothing to exit") (while (setq obj (vlax-ename->vla-object (car (entsel)))) ; vl 3d point convert to plain lisp (setq pt1 (vlax-safearray->list (vlax-variant-value (vlax-get-property obj "Location")))) Not sure but you may be able to put "Location".

This is a very simple test to make everything is inside the code including the images. next step would be to look at the Lee-mac example and use vectors rather than slides. Thanks to RLX for convert DCL. ; https://www.cadtutor.net/forum/topic/98827-the-coordinates-of-the-trapezoid/page/2/#comment-677242 ; Fill in 4 image dcl with vector images ; simple working example by AlanH Nov 2025 (setq imgslst (list (list (list 19 222 128 222 7) (list 128 222 128 114 7) (list 128 114 19 114 7) (list 19 114 19 222 7)) (list (list 37 202 119 202 7) (list 119 202 139 120 7) (list 139 120 17 120 7) (list 17 120 37 202 7)) (list (list 36 203 120 203 7) (list 120 203 101 161 7) (list 141 119 16 119 7) (list 16 119 36 203 7)(list 101 161 141 119 7)) (list (list 38 200 118 200 7) (list 118 200 99 160 7) (list 138 120 18 120 7) (list 55 168 38 200 7)(list 99 160 138 120 7)(list 55 168 18 120 7)) ) ) (defun VECTOR4 (dclkey imglst / i j) (setq i (/ (dimx_tile DCLKEY) 151.) j (/ (dimy_tile DCLKEY) 326.)) (start_image DCLKEY) (fill_image 0 0 (dimx_tile DCLKEY)(dimy_tile DCLKEY) -2) (foreach x imglst (vector_image (fix (* (car x) i))(fix (* (cadr x) j))(fix (* (caddr x) i))(fix (* (cadddr x) j))(last x)) ) (end_image) (princ) ) (defun makedcl ( / ) (setq dcl (vl-filename-mktemp nil nil ".dcl") ) (setq des (open dcl "w") ) (foreach x '( "// dd2x2 dialogue. Used by the d2x2 command in dd2x2.lsp." "// Called from the AutoCAD Release 12 Standard Menu." "dd2x2: dialog {" " label = \"Pick shape\";" " : column {" " : row {" " : image_button {" " key = \"22sq1\";" " width = 15;" " aspect_ratio = 1.0;" " color = 0;" " allow_accept = true;" " }" " : image_button {" " key = \"22sq2\";" " width = 15;" " aspect_ratio = 1.0;" " color = 0;" " allow_accept = true;" " }" " }" " : row {" " : image_button {" " key = \"22sq3\";" " width = 15;" " aspect_ratio = 1.0;" " color = 0;" " allow_accept = true;" " }" " : image_button {" " key = \"22sq4\";" " width = 15;" " aspect_ratio = 1.0;" " color = 0;" " allow_accept = true;" " }" " }" " }" "ok_cancel;" "}" ) (write-line x des ) ); foreach (close des) (princ) ) (defun wow ( / x ans dcl keynum imgsitem dclkey ) (makedcl) (setq dcl_id (load_dialog dcl)) (if (not (new_dialog "dd2x2" dcl_id) ) (exit) ) (setq keynum 1) (repeat 4 (setq imgsitem (nth (- keynum 1) imgslst)) (setq dclkey (strcat "22sq" (rtos keynum 2 0))) (VECTOR4 dclkey imgsitem) (setq keynum (1+ keynum)) ) (action_tile "22sq1" "(setq ans $key)(done_dialog)") (action_tile "22sq2" "(setq ans $key)(done_dialog)") (action_tile "22sq3" "(setq ans $key)(done_dialog)") (action_tile "22sq4" "(setq ans $key)(done_dialog)") (action_tile "accept" "(setq ans $key)(done_dialog)") (action_tile "cancel" "(setq ans $key)(done_dialog)") (start_dialog) (unload_dialog dcl_id) (vl-file-delete dcl) (princ (strcat "\nsq picked = " ans)) (princ) ) (wow)

I made some simple shapes and used Vectorize to do just that, here are some samples. next step is to look at Lee-Mac example. Only read the vectors pattern in the following code. ;******************************************************************************** ; Function to draw a vector image within a dialogue Image tile or Image Button. * ; Argument: 'DCLKEY' - the dcl key of the image tile/button to be filled. * ; Do NOT edit the dcl dimension text below, this is needed by Vectorize. * ;******************************************************************************** ; Compiled for dcl dimensions of width,24.92, height,24.97, * ;******************************************************************************** (defun VECTOR1 (DCLKEY / i j) (setq i (/ (dimx_tile DCLKEY) 151.) j (/ (dimy_tile DCLKEY) 326.)) (start_image DCLKEY) (fill_image 0 0 (dimx_tile DCLKEY)(dimy_tile DCLKEY) -15) (foreach x '((19 222 128 222 7) (128 222 128 114 7) (128 114 19 114 7) (19 114 19 222 7)) (vector_image (fix (* (car x) i))(fix (* (cadr x) j))(fix (* (caddr x) i))(fix (* (cadddr x) j))(last x))) (end_image) (princ) ) (defun VECTOR2 (DCLKEY / i j) (setq i (/ (dimx_tile DCLKEY) 151.) j (/ (dimy_tile DCLKEY) 326.)) (start_image DCLKEY) (fill_image 0 0 (dimx_tile DCLKEY)(dimy_tile DCLKEY) -15) (foreach x '((37 202 119 202 7) (119 202 139 120 7) (139 120 17 120 7) (17 120 37 202 7)) (vector_image (fix (* (car x) i))(fix (* (cadr x) j))(fix (* (caddr x) i))(fix (* (cadddr x) j))(last x))) (end_image) (princ) ) (defun VECTOR3 (DCLKEY / i j) (setq i (/ (dimx_tile DCLKEY) 151.) j (/ (dimy_tile DCLKEY) 326.)) (start_image DCLKEY) (fill_image 0 0 (dimx_tile DCLKEY)(dimy_tile DCLKEY) -15) (foreach x '((36 203 120 203 7) (120 203 101 161 7) (141 119 16 119 7) (16 119 36 203 7) (101 161 141 119 7)) (vector_image (fix (* (car x) i))(fix (* (cadr x) j))(fix (* (caddr x) i))(fix (* (cadddr x) j))(last x))) (end_image) (princ) ) (defun VECTOR4 (DCLKEY / i j) (setq i (/ (dimx_tile DCLKEY) 151.) j (/ (dimy_tile DCLKEY) 326.)) (start_image DCLKEY) (fill_image 0 0 (dimx_tile DCLKEY)(dimy_tile DCLKEY) -15) (foreach x '((38 200 118 200 7) (118 200 99 160 7) (138 120 18 120 7) (55 168 38 200 7) (99 160 138 120 7) (55 168 18 120 7)) (vector_image (fix (* (car x) i))(fix (* (cadr x) j))(fix (* (caddr x) i))(fix (* (cadddr x) j))(last x))) (end_image) (princ) ) (setq imgslst (list (list (list 19 222 128 222 7) (list 128 222 128 114 7) (list 128 114 19 114 7) (list 19 114 19 222 7)) (list (list 37 202 119 202 7) (list 119 202 139 120 7) (list 139 120 17 120 7) (list 17 120 37 202 7)) (list (list 36 203 120 203 7) (list 120 203 101 161 7) (list 141 119 16 119 7) (list 16 119 36 203 7)(list 101 161 141 119 7)) (list (list 38 200 118 200 7) (list 118 200 99 160 7) (list 138 120 18 120 7) (list 55 168 38 200 7)(list 99 160 138 120 7)(list 55 168 18 120 7)) ) ) Watch this psace. VECTORIZE.lsp

Try this. Note only do one direction at a time do lefts exit and repeat to do rights. ; https://www.cadtutor.net/forum/topic/98817-create-polyline-automatically/ ; Custom draw pline by Alan H Nov 2025 Checking if pline is CW or CCW and set to CCW ; Orignal idea by Kent Cooper, 1 August 2018 Offsetinorout.lsp ; By Alan H July 2020 ; (defun c:wow ( / co-ord ht pt0 pt1 pty1a pt2 pt2a ht oldsnap) (defun c:wow ( / ) (defun AH:chkcwccw (ent / objnew area1 area2 obj minpoint maxpoint) (setq obj (vlax-ename->vla-object ent)) (vla-GetBoundingBox obj 'minpoint 'maxpoint) (setq pointmin (vlax-safearray->list minpoint)) (setq pointmax (vlax-safearray->list maxpoint)) (setq dist (/ (distance pointmin pointmax) 20.0)) (vla-offset obj dist) (setq objnew (vlax-ename->vla-object (entlast))) (setq area1 (vlax-get objnew 'Area)) (vla-delete objnew) (vla-offset obj (- dist)) (setq objnew (vlax-ename->vla-object (entlast))) (setq area2 (vlax-get objnew 'Area)) (vla-delete objnew) (if (> area1 area2) (command "Pedit" ent "R" "") ) (princ) ) (setq oldsnap (getvar 'osmode)) (setvar 'osmode 0) (setq pt1 (getpoint "\nPick 1st point ")) (setvar 'osmode 128) (setq pt2 (getpoint pt1 "\nPick 2nd point on object ")) (setvar 'osmode 0) (setq pt0 (polar pt1 (/ pi 2.0) 4.0)) (command "pline" (setq pt1a (polar pt0 0.0 1.85)) (setq pt2a (polar pt1a (* 1.5 pi) 2.2)) (setq pt3 (polar pt2a pi 3.7)) (setq pt4 (polar pt3 (/ pi 2.0) 2.2)) "C" ) (setq ent (car (entsel "\Pick End Rectangle "))) (AH:chkcwccw ent) (setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent)))) (setq mp (mapcar '* (mapcar '+ (nth 1 co-ord) (nth 2 co-ord)) '(0.5 0.5))) (setq pt4 (polar mp (* 1.5 pi) (* 0.4 (distance (nth 0 co-ord) (nth 1 co-ord))))) (setq pt5 (mapcar '* (mapcar '+ (nth 0 co-ord) (nth 3 co-ord)) '(0.5 0.5))) (setq pt3 (list (car pt2) (cadr pt4))) (command "pline" pt0 pt1 pt2 pt3 pt4 pt5 "") (while (setq pt6 (getpoint "\nPick 1st point Enter to exit ")) (setq ang (angle pt2 pt6)) (if (and (>= ang (/ pi 2.0))(<= ang (* 1.5 pi))) (progn (setq pt0 (list (car pt6)(- (cadr pt0) 0.1))) (setq pt1 (list (car pt6)(- (cadr pt1) 0.1))) (setq pt2 (list (- (car pt2) 0.1)(- (cadr pt2) 0.1))) (setq pt3 (list (- (car pt3) 0.1)(- (cadr pt3) 0.1))) (setq pt4 (list (- (car pt4) 0.1)(- (cadr pt4) 0.1))) (setq pt5 (list (- (car pt5) 0.1)(cadr pt5))) ) (progn (setq pt0 (list (car pt6)(- (cadr pt0) 0.1))) (setq pt1 (list (car pt6)(- (cadr pt1) 0.1))) (setq pt2 (list (+ (car pt2) 0.1)(- (cadr pt2) 0.1))) (setq pt3 (list (+ (car pt3) 0.1)(- (cadr pt3) 0.1))) (setq pt4 (list (+ (car pt4) 0.1)(- (cadr pt4) 0.1))) (setq pt5 (list (+ (car pt5) 0.1)(cadr pt5))) ) ) (command "pline" (setq pt1a (polar pt0 0.0 1.85)) (setq pt2a (polar pt1a (* 1.5 pi) 2.2)) (setq pt3a (polar pt2a pi 3.7)) (polar pt3a (/ pi 2.0) 2.2) "C" ) (command "pline" pt0 pt1 pt2 pt3 pt4 pt5 "") ) (setvar 'osmode oldsnap) (princ) ) (C:wow)

These lisp's are to draw a trapezoid. I don't know if adding more features makes this completed code better. Id would have a separate code to make the irregular trapezoid and a main function to ask what shape you want to make. as far as dynamic mode modifying the poly in the drawing nothing more dynamic then that. this creates more options by call the irregular trapezoid lisp by itself or from a main list. you can even add other shapes to the main lisp. ;;----------------------------------------------------------------------------;; ;; All-Shapes or AS creates a DCL menu to pick what shape you want to create ;; and runs sub lisp of option picked ;; https://www.cadtutor.net/forum/topic/98827-the-coordinates-of-the-trapezoid/ (defun C:AS () (C:ALL-Shapes)) (defun C:All-Shapes (/ shplst shp) (setq shplst (list "Trapezoid" "Irregular Trapezoid" "Circle")) (setq shp (nth (ahlstbox "Pick a Shape" shplst 20 10) shplst)) (cond ((= shp "Trapezoid")(C:Trapezoid)) ((= shp "Irregular Trapezoid")(C:IrrTrapezoid)) ((= shp "Circle")(C:Cir)) ) ) ;; code by pkenewell (defun C:Trapezoid (/ bw p0 p1 p2 p3 p4 ra sa th) (if (and (setq bw (getreal "\nEnter the width of the Base: ") th (getreal "\nEnter the Height: ") sa (getreal "\nEnter the side angles: ") p0 (getpoint "\nSelect the insertion point: ") ) ) (progn (setq ra (* pi (/ sa 180.0)) p1 (list (- (car p0) (/ bw 2)) (cadr p0) (caddr p0)) p2 (list (+ (car p1) bw) (cadr p0) (caddr p0)) p3 (list (+ (car p2) (* (/ th (cos ra)) (sin ra))) (+ (cadr p0) th) (caddr p0)) p4 (list (- (car p1) (* (/ th (cos ra)) (sin ra))) (+ (cadr p0) th) (caddr p0)) ) (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1)) (mapcar '(lambda (x) (cons 10 x)) (list p1 p2 p3 p4)) ) ) ) ) ) (defun C:IrrTrapezoid (/ bw p0 p1 p2 p3 p4 ra sa th) (alert "Code Needed for Irregular Trapezoid") (princ) ) (defun C:Cir () (while (setq p (getpoint "\nSelect Point Center of Circle: ")) (command "_.CIRCLE" p pause) ) ) ; listbox-ah a library lst box routine pick just one from ; By Alan H March 2019 ; (if (not AHlstbox)(load "Listbox-AH.lsp")) ;(setq ans (ahlstbox "Pick a number" (list "150" "200" "225" "250" "300" "375" "450" "600") 20 10)) ; ans is returned as item number selected of the list (defun AHlstbox (heading lst wid ht / fo fname lsec ) (setq fo (open (setq fname (vl-filename-mktemp "" "" ".dcl")) "w")) (write-line "AHlstbox : dialog {" fo) (write-line (strcat " label = " (chr 34) heading (chr 34) " ;" ) fo) (write-line " spacer ; " fo) (write-line " :list_box { " fo) (write-line (strcat " key=" (chr 34) "lst" (chr 34) " ; ") fo) (write-line (strcat " multiple_select=" (chr 34) "false" (chr 34) " ; ") fo) (write-line (strcat " width= " (rtos wid 2 0) " ; ") fo) (write-line (strcat " height=" (rtos ht 2 0 ) " ; ") fo) (write-line " } " fo) (write-line "spacer ;" fo) (write-line " ok_cancel ; " fo) (write-line " } " fo) (close fo) (setq dcl_id (load_dialog fname)) (if (not (new_dialog "AHlstbox" dcl_id)) (exit) ) (start_list "lst") (foreach itm lst (add_list itm)) (end_list) (action_tile "lst" "(setq lsec (atoi $value) )") (start_dialog) (unload_dialog dcl_id) (vl-file-delete fname) (princ lsec) )

Here I've revised Helmut's code and made it faster. ;; ; ;; Pathfinding with the A* algorithm by ymg 22/07/2024 ; ;; ; ;; Revised a prog by HELMUT SCHRÖDER - heschr@gmx.de - 2014-09-14 ; ;; found at Cadtutor.net ; ;; ; ;; Kept the same format for edges list but added lines as valid choice ; ;; Format: (((x1 y1) (x2 y2)) (((x2 y2) (x3 y3))....(xn yn))) ; ;; ; ;; The user is asked to pick a start and an endpoint. ; ;; The program will find the shortest path in a network of connected ; ;; polylines and/or lines and draw a new polyline representing the result. ; ;; ; ;; Two lists of nodes openlst and closelst are created from the above ; ;; mentionned edges list. The format of a node list is: ; ;; (((Point) (Prev Point) Cumulated_Distance Estimated_Total_Distance)...) ; ;; ; ;; Main change from origina are: ; ;; - cons the list instead of append ; ;; - vl-sort the openlist instead of the quicksort ; ;; - Replaced and renamed some vars and subroutine. ; ;; - Added fuzz 1e-4 to all points comparison ; ;; - Change the get_path function ; ;; - Added line as possible edges ; ;; - Added an error handler ; ;; - Added a timer to the search portion of the program ; ;; ; ;; The above changes amounted to an acceleration of about 4x from the ; ;; original program. ; ;; : ;; If you compile this program to a .fas you'll get more than 10x faster. ; ;; ; (defun c:A* ( / ssl ssp i edges startp endp openlst closelst found acdoc Edgelay Pathlay Pathcol Pathlwt) (vl-load-com) ; Changes values of following 4 global variables to suit your need. ; (setq Edgelay "Edges" Pathlay "Path" Pathcol 1 ; 1=Red 2=Yellow etc. ; Pathlwt 70 ; lineweight for path 0.7mm ; ) (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))) (set_errhandler '("CLAYER" "OSMODE" "CMDECHO")) (setvar 'CMDECHO 0) (setvar 'OSMODE 1) (if (setq ssp (ssget '"X" (list (cons 0 "LWPOLYLINE") (cons 8 Edgelay)))) (foreach en (mapcar (function cadr) (ssnamex ssp)) (setq edges (append edges (mk_edge (listpol2d en)))) ) ) (if (setq ssl (ssget '"X" (list (cons 0 "LINE") (cons 8 Edgelay)))) (foreach en (mapcar (function cadr) (ssnamex ssl)) (setq edges (cons (list (butlast (vlax-curve-getstartpoint en)) (butlast (vlax-curve-getendpoint en))) edges)) ) ) (setq startp (butlast (getpoint "\nPick Start Point: ")) ; Startpoint - reduced to 2D ; endp (butlast (getpoint "\nPick End Point: ")) ; Endpoint - reduced to 2D ; openlst (list (list startp '(0 0) 0.0 (distance startp endp))) ; Add starting node to openlst ; ) (vla-startundomark acdoc) (setq ti (getvar 'MILLISECS)) (while (and openlst (not found)) (setq node (car openlst)) (if (equal (car node) endp 1e-4) (setq found T closelst (cons node closelst)) (setq closelst (cons node closelst) openlst (upd_openlst edges node endp (cdr openlst) closelst) ) ) ) (if found (mk_lwp (get_path closelst)) (alert "No path was found") ) (princ (strcat "\nExecution time:" (itoa (- (getvar 'MILLISECS) ti)) " milliseconds.")) (*error* nil) ) ;; ; ;; upd_openlst ; ;; ; ;; Each node of the openlst is passed to this sub and we scan the edges list ; ;; to find the corresponding edges. Then both points of the edges are tested ; ;; for equality to the nodes. The fixed cost (distance) is updated and so is ; ;; the estimated total distance. Updates are first put in a temporary node. ; ;; ; ;; We then proceed to test if the temp variable is already in the closelst ; ;; and proceed to the next edge. ; ;; ; ;; If temp is true and temp is not in closelst we go to the recursive sub ; ;; in_openlst which adjust the values and return the updated openlst : ;; ; ;; Upon return we sort the openlst on smallest estimated distance ; ;; and return the openlst to the main routine ; ;; ; (defun upd_openlst (edges node endp openlst closelst / pt fcost p1 p2 d temp) (setq pt (car node) fcost (caddr node)) (while edges (setq p1 (caar edges) p2 (cadar edges) edges (cdr edges) d (distance p1 p2) temp nil) ;Testing both points of an edge and building a temporary node ; (cond ((equal pt p1 1e-4) (setq temp (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp))))) ((equal pt p2 1e-4) (setq temp (list p1 p2 (+ fcost d) (+ fcost d (distance p1 endp))))) ) (if (and temp (not (memberfuzz (car temp) closelst))) (setq openlst (in_openlst temp openlst)) ) ) ; Keep openlist sorted on smallest Estimated Total Cost ; (print (vl-sort openlst (function (lambda(a b)(< (cadddr a) (cadddr b))))) ) ) ;in_lst Replaced by memberfuzz ; ;(defun in_lst (pt lst) ; (cond ; ((not lst) nil) ; ((equal pt (caar lst) 1e-4) lst) ; (T (in_lst pt (cdr lst))) ; ) ;) ; returns a new openlst with a double exchanged if cost is lower ; ;; ; (defun in_openlst (node lst) (cond ((not lst) (list node)) ((equal (car node) (caar lst) 1e-4) (if (< (cadddr node) (cadddr (car lst))) (cons node (cdr lst)) lst ) ) (T (cons (car lst) (in_openlst node (cdr lst)))) ) ) (defun in_openlst2 (node lst / s c) (setq s (splitat (caar node) lst) c (cadddr node)) (cond ((not lst) (list node)) ((not (car s)) (cons node (cadr s))) ((not (cadr s)) (cons node (car s))) (T (if (< (cadddr node) (cadddr (cadr s))) (append (car s) (cons node (cdr s))) lst )) ;(T (c ns node lst)) ) ) ;; ; ;; listpol2D by ymg (Simplified a Routine by Gile Chanteau ; ;; ; ;; Parameter: en, Entity Name or Object Name of Any Type of Polyline ; ;; ; ;; Returns: List of Points in 2D WCS ; ;; ; ;; Notes: Requires butlast function for 2d points. ; ;; ; (defun listpol2d (en / i lst) (repeat (setq i (fix (1+ (vlax-curve-getEndParam en)))) (setq lst (cons (butlast (vlax-curve-getPointAtParam en (setq i (1- i)))) lst)) ) ) ;; ; ;; mk_edge ; ;; ; ;; From a list of consecutives points as supplied by listpol2D, ; ;; Returns a list of edges (((x1 y1)(x2 y2)) ((x2 y2)(x3 y3))...) ; ;; ; (defun mk_edge (lst) (mapcar (function (lambda (a b) (list a b ))) lst (cdr lst)) ) ;; ; ;; butlast ; ;; ; ;; Returns a list without the last item ; ;; Used here mainly to change points to 2D ; ;; ; (defun butlast (lst) (reverse (cdr (reverse lst)))) ;; ; ;; get_path ; ;; ; ;; Returns The list of points of shortest path found from closelst. ; ;; ; (defun get_path (lst / path) (setq path (list (caar lst)) prev (cadar lst) lst (cdr lst)) (while (setq lst (memberfuzz prev lst)) (setq prev (cadar lst) path (cons (caar lst) path) ) ) path ) ;; ; ;; memberfuzz by Gile Chanteau ; ;; ; ;; Modified to work with nodes list ; ;; ; (defun memberfuzz (p lst) (while (and lst (not (equal p (caar lst) 1e-4))) (setq lst (cdr lst)) ) lst ) (defun splitat (p lst / tr) (while (and lst (not (equal p (caar lst) 1e-4))) (setq tr (cons (car lst) tr) lst (cdr lst)) ) (list (reverse tr) lst) ) (defun truncfuzz (p lst) (if (and lst (not (equal p (caar lst) 1e-4))) (cons (car lst) (truncfuzz p (cdr lst))) ) ) (defun posfuzz (p lst) (- (length lst) (length (memberfuzz p lst))) ) (defun rotleft (lst) (append (cdr lst) (list (car lst)))) (defun rotright (lst) (cons (last lst) (butlast lst))) ;; ; ;; mk_lwp ; ;; ; ;; Draw an lwpolyline given a point list ; ;; ; ;; Will be drawn on layer with color and lineweight defined by Variables ; ;; at beginnung of program. ; ;; ; (defun mk_lwp (pl) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 8 Pathlay) (cons 62 Pathcol) (cons 90 (length pl)) (cons 70 0) (cons 370 Pathlwt) ) (mapcar (function (lambda (a) (cons 10 a))) pl) ) ) ) ;; Error Handler by Elpanov Evgenyi ; (defun set_errhandler (l) (setq varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) l)) ) (defun *error* (msg) (mapcar 'eval varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (vla-endundomark acdoc) (princ) ) (princ "A* to start") Astar rev3.lsp astar test.dwg

See attached. It does not set layers, but I use this to generate curb offsets, based on multiple selected lines/etc. OffsetMultiple.lsp