Leaderboard

Why get fancy? (max 0 (- botLength 6000))

I had these for a bit and figured I'd share. I was surprised I couldn't find anything to rename the layout tab automatically, I am probably the only person too lazy to type them in, if there are some LISPs out there I couldn't find them. They do what I need, but I am sure more options could be added and most likely improved so feel free to comment or ask, no guarantee I can get time to work on them in the near future. I am busy busy at work right now. I use the first and last one the most. I have them set for drag and drop, just comment or delete the (c:---------) at the bottom to not run on load. The first I had for a bit, I just drag and drop into a drawing with a single tab and the tab name is the drawing name. ;;; Layout tab with drawing name. (Works with only one layout tab) ;;; ;;; By SLW210 (a.k.a. Steve Wilson) ;;; (defun c:DwgNameLayTab () (setq dName (vl-filename-base (getvar "DWGNAME"))) (setq lout (vla-get-ActiveLayout (vla-get-ActiveDocument (vlax-get-acad-object)))) (vla-put-Name lout dName) ) (c:DwgNameLayTab) Another one I did, does same as above, but if more than one tab adds -1, -2, etc. ;;; Adds suffix to drawing name in layout tabs, if one tab dwgname only. ;;; ;;; By SLW210 (a.k.a. Steve Wilson) ;;; (defun c:LayoutNameFromDWG ( / dwgName layouts layCount addSuffix idx doc layObj) (vl-load-com) ;; Get drawing name without extension (setq dwgName (vl-filename-base (getvar "DWGNAME"))) ;; Get list of layouts excluding Model (setq layouts (vl-remove "Model" (layoutlist))) (setq layCount (length layouts)) ;; Determine suffix behavior (cond ;; Only one layout no suffix ((= layCount 1) (setq addSuffix nil) ) ;; More than one layout suffix REQUIRED ((> layCount 1) (setq addSuffix T) ) ) ;; Get active document (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) ;; Rename layouts (setq idx 1) (foreach lay layouts (setq layObj (vla-item (vla-get-Layouts doc) lay)) (vla-put-Name layObj (if addSuffix (strcat dwgName "-" (itoa idx)) dwgName ) ) (setq idx (1+ idx)) ) (princ "\nLayout tabs renamed successfully.") (princ) ) (c:LayoutNameFromDWG) This does the exact same as the LayoutNameFromDWG.lsp , I think I had lost it and rewrote it, I don't see any advantage in one over the other, maybe someone else can tell. ;;; Layout tab with drawing name adds suffix if more than one tab (-1, -2). ;;; ;;; By SLW210 (a.k.a. Steve Wilson) ;;; (defun c:DwgNameLayTab1 ( / dName doc layouts layCount idx lout) (vl-load-com) ;; Drawing name (no extension) (setq dName (vl-filename-base (getvar "DWGNAME"))) ;; Get document and layouts (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (setq layouts (vl-remove "Model" (layoutlist))) (setq layCount (length layouts)) ;; Rename layouts (setq idx 1) (foreach lay layouts (setq lout (vla-item (vla-get-Layouts doc) lay)) (vla-put-Name lout (if (> layCount 1) (strcat dName "-" (itoa idx)) dName ) ) (setq idx (1+ idx)) ) (princ) ) (c:DwgNameLayTab1) This one does a bit more, first tab is the DwgName, if more than one tab it adds a suffix to the second, third, etc. but first tab is still DwgName only, if as is often my case the DwgName ends in a number like I often have M-10-001, it just adds 1 to each of the next tabs. Example, M-10-001,M-10-002, M-10-003, M-10-004, etc. ;;; Layout tab drawing name to first tab, more than one tab adds suffix after first tab (-1, -2), if ends in numbers adds 1 to number ;;; for example M-10-001,M-10-002, M-10-003, M-10-004. ;;; ;;; By SLW210 (a.k.a. Steve Wilson) ;;; (defun c:DwgNameLayTab2 ( / dName doc layouts idx lout baseName numStr startNum numLen pos) (vl-load-com) ;; Drawing name (no extension) (setq dName (vl-filename-base (getvar "DWGNAME"))) ;; Get layouts (exclude Model) (setq layouts (vl-remove "Model" (layoutlist))) ;; Extract trailing number (with padding) --- (setq pos (strlen dName)) (while (and (> pos 0) (<= 48 (ascii (substr dName pos 1)) 57)) (setq pos (1- pos)) ) (if (< pos (strlen dName)) (progn (setq baseName (substr dName 1 pos)) (setq numStr (substr dName (1+ pos))) (setq startNum (atoi numStr)) (setq numLen (strlen numStr)) ;; number of digits ) (setq baseName dName startNum 1 numLen 0) ) ;; Get document (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) ;; Rename layouts (setq idx 0) (foreach lay layouts (setq lout (vla-item (vla-get-Layouts doc) lay)) (vla-put-Name lout (cond ;; First layout: exact drawing name ((= idx 0) dName) ;; Subsequent layouts (T (if (> numLen 0) ;; DWG ends with number increment & pad (strcat baseName (vl-string-right-trim " " (strcat (substr "0000000000" 1 (- numLen (strlen (itoa (+ startNum idx))))) (itoa (+ startNum idx)) ) ) ) ;; No trailing number add -1, -2, ... (strcat dName "-" (itoa idx)) ) ) ) ) (setq idx (1+ idx)) ) (princ) ) (c:DwgNameLayTab2)

As I said, this code doesn't work in some special cases. However, in the cases where it does work, it returns surprising results. I've attached a short video to illustrate this. CLG_xple.mp4

Are you using a localized version of AutoCAD? Try this option. ; By Alan H AUG 2019 / modification ; offset sides pline.lsp - original ; draw offsets from points for random shape object making pline ; https://www.cadtutor.net/forum/topic/98954-smart-offset-lisp/ ; Added characters (_) for localized versions of Autocad. ; You select the points sequentially, and the program draws the offsets. Right-right-down / Left-left-up ; Be sure to press Enter or rmb (right mouse button) to complete the selection of points, ; this way, the program will smooth out all the offset segments (i.e. combine them into a polyline). ; added memorization of the last offset distance selection ; Added backlight for selecting [Right/Left], [Swap sides] (defun c:ploffs-m (/ offdir offd x pt1 pt2 pt3 oldsnap ssp) (defun drawline (/ ang pt3 obj) (setq ang (angle pt1 pt2)) (if (= offdir "L") (setq pt3 (polar pt2 (+ ang (/ pi 2.0)) 10)) (setq pt3 (polar pt2 (- ang (/ pi 2.0)) 10)) ) (setvar 'osmode 0) (command "_.line" pt1 pt2 "") (setq obj (entlast)) (command "_.offset" offd obj pt3 "") (setq ssp (ssadd (entlast) ssp)) (command "_.erase" obj "") (setq pt1 pt2) ) (defun swapr-l (/) (if (= (strcase offdir) "L") (setq offdir "R") (setq offdir "L") ) (setvar 'osmode oldsnap) (setq pt1 (getpoint "\nPick next point")) (setq pt2 (getpoint "\nPick next point")) (drawline) ) ; add side pick (setq oldsnap (getvar 'osmode)) (setq ssp nil) (initget 6 "R L") ; (setq offdir (strcase (getstring "Right or Left"))) (setq offdir (strcase (getstring "[Right/Left]"))) ;; --- remember last offset distance --- (if (not (boundp '*lastOffD*)) (setq *lastOffD* (if (getenv "MY_LAST_OFFD") (atof (getenv "MY_LAST_OFFD")) 10.0 ; (offset distance By default) ) ) ) (setq offd (getreal (strcat "\nEnter offset distance <" (rtos *lastOffD* 2 4) ">: "))) (if (null offd) (setq offd *lastOffD*) (progn (setq *lastOffD* offd) (setenv "MY_LAST_OFFD" (rtos offd 2 8)) ) ) ;; --- /remember last offset distance --- (setq pt1 (getpoint "pick 1st point")) (setq ssp (ssadd)) (initget 6 "1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z") (while (setq pt2 (getpoint "\nPick next point or [Swap sides]:<")) (cond ((= (type pt2) 'LIST) (drawline)) ((= (type pt2) 'str) (swapr-l)) ; also calls drawlines ((= pt2 nil) (quit)) ) (setvar 'osmode oldsnap) (initget 6 "Swap") ) (setq x 0) (repeat (- (sslength ssp) 1) (setvar 'filletrad 0) (command "_.fillet" (ssname ssp x) (ssname ssp (1+ x))) (setq x (1+ x)) ) (setq x 0) (command "_.pedit" (entlast) "_Y" "_J") ; if "Join" doesn't work, try the line below without the "_Y" ;(command "_.pedit" (entlast) "_J") (repeat (- (sslength ssp) 1) (command (ssname ssp x)) (setq x (1+ x)) ) (command "" "") (princ) )

I implemented astar using a heap instead of the dictionnary proposed by @GLAVCVS. Safearray is used to simulate the heap. Was done with prompt in Google AI. Results the heap is faster specially if the graph is bigger. ;; ; ;; c:A* by ymg ; ;; Astar implemented with a Heap instead of a dictionnary ; ;; Edges of the Graph are drawn on layer identified by Golbal #Edgeslay ; ;; ; ;; Edges can be lines, lpolylines or 3dpolylines ; ;; You select Start and End points. Shortest is then found and drawn as a ; ;; 3D Polylines on layer, color and lineweight chosen via Global vars ; ;; found at beginning of this routine ; ;; ; ;; Heap has a faster running time than the dictionnary and list approach ; ;; as the size of the graph grows. ; ;; ; (defun c:A* (/ ss graph openH gScore cameFrom found cur curPt curK sNode sKey neighbor nKey t_g val oldG oldCF Startp Endp d minD en param endpar p1 p2 path k link pt i ti) (vl-load-com) (or #acdoc (setq #acdoc (vla-get-activedocument (vlax-get-acad-object)))) (set_errhandler '("CLAYER" "OSMODE" "CMDECHO" "DIMZIN")) (setvar 'CMDECHO 0) (setvar 'OSMODE 1) (setq #Edgelay "Edges" #Pathlay "Path" #Pathcol 1 #Pathlwt 70 #Hptr 0 ) ;; Selecting set of entities defining edges of graph. (if (not (setq ss (ssget "X" (list '(0 . "LINE,LWPOLYLINE,POLYLINE") (cons 8 #Edgelay))))) (progn (alert (strcat "\nError: No entities found on layer " #Edgelay)) (exit) ) ) (vla-startundomark #acdoc) ;; Geting Start and End points. (Use snap to endpoint) (setq Startp (getpoint "\nPick Start Point: ")) (mk_circle Startp 7.5 #Pathcol) (setq Endp (getpoint "\nPick End Point: ")) (mk_circle Endp 7.5 3) (setq ti (getvar 'MILLISECS)) ;Timer for execution time ; Building Graph... (setq graph nil i 0) (repeat (sslength ss) (setq en (ssname ss i) ent (entget en) param 0 endpar (vlax-curve-getEndParam en) i (1+ i) ) (while (< param endpar) (if (= (cdr (assoc 0 ent)) "LINE") (setq p1 (vlax-curve-getstartpoint en) p2 (vlax-curve-getendpoint en) param (1+ endpar) ) (setq p1 (vlax-curve-getPointAtParam en param) p2 (vlax-curve-getPointAtParam en (setq param (1+ param))) ) ) (setq k1 (pt->key p1) k2 (pt->key p2) graph (update-g graph k1 p1 p2) graph (update-g graph k2 p2 p1) ) ) ) (setq minD 1.7e308) ; Initialize to infinity (foreach entry graph (if (< (setq d (distance (cadr entry) Startp)) minD) (setq minD d sNode entry) ) ) (setq sKey (car sNode) openH (heap:new (length graph)) gScore (list (cons sKey 0.0)) cameFrom nil found nil ) (heap:push openH (distance (cadr sNode) Endp) (cadr sNode)) (setq gbti (- (getvar 'MILLISECS) ti)) ;Start of Pathfinding... (while (and (> #Hptr 0) (not found)) (setq cur (heap:pop openH) curPt (cdr cur) curK (pt->key curPt) ) (if (< (distance curPt Endp) 0.1) (setq found T) (foreach neighbor (cddr (assoc curK graph)) (setq nKey (pt->key neighbor) val (assoc curK gScore) t_g (+ (cdr val) (distance curPt neighbor)) ) (if (or (null (setq oldG (assoc nKey gScore))) (< t_g (cdr oldG))) (progn (if oldG (setq gScore (vl-remove oldG gScore))) (setq gScore (cons (cons nKey t_g) gScore)) (if (setq oldCF (assoc nKey cameFrom)) (setq cameFrom (subst (cons nKey curPt) oldCF cameFrom)) (setq cameFrom (cons (cons nKey curPt) cameFrom)) ) (heap:push openH (+ t_g (distance neighbor Endp)) neighbor) ) ) ) ) ) ;; Result Handling (if found (progn (setq path (list curPt) k curK ) (while (setq link (assoc k cameFrom)) (setq pt (cdr link) k (pt->key pt) path (cons pt path) ) ) (mk_3dp path) ) (princ "\nNo path found.") ) (vla-endundomark #acdoc) (setq totaltime (- (getvar 'MILLISECS) ti)) (princ "\n ----- A* Optimized With Gemini ----- ") (princ (strcat "\n Graph Size: " (itoa (length graph)) " nodes")) (princ (strcat "\n Graph Building Time: " (itoa gbti) " ms.")) (princ (strcat "\n Pathfinding Time: " (itoa (- totaltime gbti)) " ms.")) (princ (strcat "\nTotal Execution time: " (itoa totaltime) " ms.")) (*error* nil) ) ;; ; ;; ERROR HANDLING & SYSTEM UTILITIES ; ;; ; ;; ; ;; set_errhandler by Elpanov Evgenyi ; ;; Captures system variable states into global #varl. ; ;; Argument 'l': List of strings naming system variables. ; ;; ; (defun set_errhandler (l) (setq #varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) l)) ) ;; ; ;; *error* by Elpanov Evgenyi ; ;; Redefines the *error* function and display an error message. ; ;; Restores system variables and handles exit messages. ; ;; ; (defun *error* (msg) (mapcar 'eval #varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (princ) ) ;; ; ;; Heap Abstraction Utilities Using Safearray ; ;; ; ;; ; ;; heap:new ; ;; ; ;; Initializes a Variant Safearray as a Minimum-Heap and set the Heap pointer ; ;; Global Var #Hptr to 0 ; ;; ; ;; Argument: size, Total capacity for the Heap. ; ;; ; ;; Return : Safearray Object ; ;; ; (defun heap:new (size) (setq #Hptr 0) (vlax-make-safearray vlax-vbVariant (cons 0 (max 1 (1- size))) '(0 . 1)) ) ;; ; ;; heap:get ; ;; ; ;; Fetch node data at given index in the heap ; ;; ; ;; Arguments: h, Heap name as a safearray object ; ;; idx, Index of the node ; ;; ; ;; Returns: A dotted pair, (Priority . Point) ; ;; ; (defun heap:get (h idx) (cons (vlax-variant-value (vlax-safearray-get-element h idx 0)) (vlax-safearray->list (vlax-variant-value (vlax-safearray-get-element h idx 1))) ) ) ;; ; ;; heap:set ; ;; ; ;; Writes priority and point into heap at index. ; ;; Arguments: h, heap name ; ;; i, index ; ;; prio, double ; ;; p, point. ; ;; ; (defun heap:set (h i prio p / arr) (setq arr (vlax-make-safearray vlax-vbDouble '(0 . 2))) (vlax-safearray-fill arr (mapcar 'float p)) (vlax-safearray-put-element h i 0 (vlax-make-variant prio vlax-vbDouble)) (vlax-safearray-put-element h i 1 arr) ) ;; ; ;; heap:swap ; ;; ; ;; Swaps two elements the heap ; ;; ; ;; Arguments: h, heap name ; ;; i, index of first element ; ;; j, index of second element ; ;; ; (defun heap:swap (h i j / tp tv) (setq tp (vlax-safearray-get-element h i 0) tv (vlax-safearray-get-element h i 1) ) (vlax-safearray-put-element h i 0 (vlax-safearray-get-element h j 0)) (vlax-safearray-put-element h i 1 (vlax-safearray-get-element h j 1)) (vlax-safearray-put-element h j 0 tp) (vlax-safearray-put-element h j 1 tv) ) ;; ; ;; heap:push ; ;; Adds a node, re-sorts heap via sift-up and adjust the heap pointer ; ;; ; ;; Arguments: h, heap name ; ;; prio, priority ; ;; pt, point ; ;; ; ;; Returns: Value of heap pointer ; ;; ; (defun heap:push (h prio pt / i p) (heap:set h #Hptr prio pt) (setq i #Hptr) (while (and (> i 0) (< prio (car (heap:get h (setq p (/ (1- i) 2)))))) (heap:swap h i p) (setq i p) ) (setq #Hptr (1+ #Hptr)) ) ;; ; ;; heap:pop ; ;; ; ;; Removes root node, re-sorts the heap by sift-down updates #Hptr ; ;; ; ;; Argument: h, heap name ; ;; ; ;; Return: root node as dotted pair (Priority . Point) ; ;; ; (defun heap:pop (h / root size i l r s i-prio l-prio r-prio) (if (> #Hptr 0) (progn (setq root (heap:get h 0) #Hptr (1- #Hptr)) (if (> #Hptr 0) (progn (heap:swap h 0 #Hptr) (setq i 0 size #Hptr) (while (< (setq l (1+ (* i 2))) size) (setq r (1+ l) ;; Get priorities once to avoid redundant safearray lookups i-prio (vlax-variant-value (vlax-safearray-get-element h i 0)) l-prio (vlax-variant-value (vlax-safearray-get-element h l 0)) s l ) ;; Check if right child exists and is smaller than left (if (and (< r size) (< (setq r-prio (vlax-variant-value (vlax-safearray-get-element h r 0))) l-prio)) (setq s r l-prio r-prio)) ;; Update smallest index and priority ;; If smallest child is smaller than current, swap (if (< l-prio i-prio) (progn (heap:swap h i s) (setq i s)) (setq i size)) ;; Else, heap property restored ) ) ) root ) ) ) ;; ; ;; GRAPH & DRAWING UTILITIES ; ;; ; ;; ; ;; pt->key ; ;; Converts 3D point to a string key "X,Y,Z". ; ;; Argument 'p': 3D point list. ; ;; ; (defun pt->key (p) (strcat (rtos (car p) 2 2) " " (rtos (cadr p) 2 2) " " (rtos (caddr p) 2 2))) ;; ; ;; update-g ; ;; Links nodes in graph association list. ; ;; ; ;; Arguments: g, graph list ; ;; k, key ; ;; p, point ; ;; n, neighbor. ; ; ;; ; (defun update-g (g k p n / ex) (if (setq ex (assoc k g)) (subst (append ex (list n)) ex g) (cons (list k p n) g) ) ) ;; ; ;; mk_3dp by Alan J Thompson ; ;; ; ;; Entmakes a 3D Polyline. Global Vars #Pathlay, #Pathcol and #Pathlwt have ; ;; to be set in calling program. ; ;; ; ;; Argument: lst, List of 3D points. ; ;; ; ;; Returns: Entity Name of Polyline ; ;; ; (defun mk_3dp (lst / vtx) (if (and lst (> (length lst) 1)) (progn (entmakex (list '(0 . "POLYLINE") '(10 0. 0. 0.) (cons 8 #Pathlay) (cons 62 #Pathcol) (cons 370 #Pathlwt) '(70 . 8) ) ) (foreach vtx lst (entmakex (list '(0 . "VERTEX") (cons 10 vtx) '(70 . 32) ) ) ) (entmakex '((0 . "SEQEND"))) ) ) ) (defun mk_circle (ctr rad color) (entmakex (list (cons 0 "CIRCLE") (cons 10 ctr) (cons 40 rad) (cons 8 #Pathlay) (cons 62 color) (cons 370 #Pathlwt) ) ) ) (princ "\nCommand A* loaded.") (princ) Astar3dHeap.LSP

Here's an old one CAB wrote. dz.lsp

Hi, it's me again... I've implemented lastly coded interventions by @GLAVCVS into my cleaned version... It should work well with user selection of network entities... Still filter for selection is now very robust, but it seems that it should be coded like that (I don't know how to make it better - shorter)... I think that this version fulfills any situation that may occur LINES, POLYLINES (2D-Heavy, 3D), LWPOLYLINES (without arced segments). If you see something I missed, please don't hasitate to inform - post reply... ;; 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 z1) (x2 y2 z2)) ((x2 y2 z2) (x3 y3 z3))....) ; ;; ; ;; The user is asked to pick a start and an endpoint. ; ;; The program will find the shortest path in a network of connected ; ;; lines and draw a new 3dpolyline 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. ; ;; ; ;| Added or modified code by GLAVCVS (january 2026) -All set are grouped into one -An associative sparse matrix cell->handles is created for faster cell querying (using new 'addToDict' and 'getCell' functions) -The "edges" list is replaced with the local search retourned by 'getCell' T E S T S ===== fas: 4-5 x faster than previous fas lsp: 7-8 x faster than previous lsp |; (defun c:A* (/ *error* addToDict getCell upd_openlst in_openlst get_path memberfuzz mk_lwp f3Dpol LM:rtos set_errhandler sspl i startp endp e openlst closelst found acdoc lstClvs Pathlay Pathcol Pathlwt varl node ti ) (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com)) (defun *error* (msg) (if e (if command-s (command-s "_.draworder" e "" "_f") (vl-cmdf "_.draworder" e "" "_f") ) ) (mapcar (function eval) varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (vla-endundomark acdoc) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS ;;;Create dictionary (defun addToDict (en / p val id clv i l c a) (setq i -1 id (cdr (assoc 5 (setq l (entget en)))) c (= (cdr (assoc 0 l)) "LINE") a 10) (while (setq p (if (and (setq i (1+ i)) c) (cdr (assoc (+ a i) l)) (vlax-curve-getPointAtParam en i))) (if (setq val (assoc (setq clv (strcat (LM:rtos (car p) 2 4) "," (LM:rtos (cadr p) 2 4) "," (LM:rtos (caddr p) 2 4))) lstClvs)) (setq lstClvs (subst (append val (list (cons id i))) val lstClvs)) (setq lstClvs (cons (list clv (cons id i)) lstClvs)) ) ) ) ;;;return list cell ;;*** Modified to access the new dictionary format *** (defun getCell (pt / val clv lr pr par l c oc p0 p) (defun oc (c e i) (if c (cdr (assoc (+ i 10) l)) (vlax-curve-getPointAtParam e i))) (if (setq val (assoc (setq clv (strcat (LM:rtos (car pt) 2 4) "," (LM:rtos (cadr pt) 2 4) "," (LM:rtos (caddr pt) 2 4))) lstClvs)) (foreach par (cdr val) (setq e (handent (car par)) c (= (cdr (assoc 0 (setq l (entget e)))) "LINE")) (if (zerop (setq pr (cdr par))) (setq lr (cons (list (oc c e pr) (oc c e (1+ pr))) lr)) (setq lr (cons (list (oc c e (1- pr)) (setq p0 (oc c e pr))) lr) lr (if (setq p (oc c e (1+ pr))) (cons (list p0 p) lr) lr) ) ) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ; ;; 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 (node endp openlst closelst / lEdges pt fcost p1 p2 d temp) (setq pt (car node) fcost (caddr node) ) (setq lEdges (getCell pt)) (foreach edge lEdges (setq p1 (car edge) p2 (cadr edge) d (distance p1 p2) temp nil ) (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)) ) ) (vl-sort openlst (function (lambda (a b) (< (cadddr a) (cadddr b))))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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)))) ) ) ;; ; ;; 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 ) ;; ; ;; f3Dpol ; ;; ; ;; Draw an 3dpolyline given a point list ; ;; ; ;; Will be drawn on layer, lineweight and color defined by Variables ; ;; at beginnung of program. ; ;; ; (defun f3Dpol (pts c / ep ll la e) (setq ep (if (= 1 (getvar (quote cvport))) (vla-get-PaperSpace acdoc) (vla-get-ModelSpace acdoc)) ll (apply (function append) pts) la (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length ll)))) (mapcar (function float) ll)) e (vla-Add3DPoly ep la) ) (vla-put-Color e c) (vla-put-Layer e Pathlay) (vla-put-Lineweight e Pathlwt) (vlax-vla-object->ename e) ) ;; ; ;; 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 (* 128 (getvar (quote plinegen)))) (cons 370 Pathlwt) ) (mapcar (function (lambda (a) (cons 10 a))) pl) ) ) ) ;; A wrapper for the rtos function to negate the effect of DIMZIN - Lee Mac (defun LM:rtos (real units prec / dimzin result) (setq dimzin (getvar (quote dimzin))) (setvar (quote dimzin) 0) (setq result (vl-catch-all-apply (function rtos) (list real units prec))) (setvar (quote dimzin) dimzin) (if (not (vl-catch-all-error-p result)) result ) ) ;; Error Handler by Elpanov Evgenyi ; (defun set_errhandler (l) (setq varl (mapcar (function (lambda (a) (list (quote setvar) a (getvar a)))) l)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Change values of following 3 variables to suit your need. ; (setq Pathlay "0" Pathcol 3 ; 1=Red 2=Yellow 3=Green etc. ; Pathlwt 30 ; lineweight for path 0.3 mm ; ) (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))) (set_errhandler (list "clayer" "osmode" "cmdecho")) (setvar (quote cmdecho) 0) (setvar (quote osmode) 1) (setvar (quote lwdisplay) 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (prompt "\nSelect LINE and polygonal POLYLINE network entities...") (if (setq sspl (ssget (list (cons -4 "<or") (cons 0 "LINE") (cons -4 "<and") (cons 0 "POLYLINE") (cons -4 "<or") (cons 70 8) (cons 70 9) (cons 70 0) (cons 70 1) (cons 70 128) (cons 70 129) (cons -4 "or>") (cons -4 "and>") (cons -4 "<and") (cons 0 "LWPOLYLINE") (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>") (cons -4 "and>") (cons -4 "or>")))) (foreach en (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex sspl))) (addToDict en) ) ) (initget 1) (setq startp (getpoint "\nPick or specify Start Point : ")) (initget 1) (setq endp (getpoint "\nPick or specify End Point : ")) (setq openlst (list (list startp (list 0.0 0.0 0.0) 0.0 (distance startp endp)))) (vla-startundomark acdoc) (setq ti (getvar (quote 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 node endp (cdr openlst) closelst)) ) ) (if found (if (vl-some (function (lambda (x) (not (equal (last x) 0.0 1e-4)))) (setq path (get_path closelst))) (setq e (f3Dpol path Pathcol)) (setq e (mk_lwp path)) ) (alert "No path was found...") ) (princ (strcat "\nExecution time : " (itoa (- (getvar (quote millisecs)) ti)) " milliseconds...")) (*error* nil) ) HTH. Regards, M.R.

I forgot to include the creation of the 3D polyline. This last code creates the path in 2D or 3D as needed. ;; 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. ; ;; ; ;| Added or revised code by GLAVCVS (january 2026) -All set are grouped into one -An associative sparse matrix cell->handles is created for faster cell querying (using new 'addToDict' and 'getCell' functions) -The "edges" list is replaced with the local search retourned by 'getCell' T E S T S ===== fas: 4-5 x faster than previous fas lsp: 7-8 x faster than previous lsp |; (defun c:A* (/ sspl i edges startp endp openlst closelst found acdoc Edgelay Pathlay Pathcol Pathlwt lstClvs path ) (vl-load-com) ; Changes values of following 4 global variables to suit your need. ; (setq Edgelay "0" Pathlay "0" 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)) ;;; (addToDict en) ;;; (setq edges (append edges (mk_edge (listpol2d en)))) ;;; ) ;;; nil ;;; ) ;;; ;;; (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 ;;; ) ;;; ) ;;; ) ;;; ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS (if (setq sspl (ssget "X" (list '(0 . "*LINE") (cons 8 EdgeLay)))) (foreach en (mapcar (function cadr) (ssnamex sspl)) (addToDict en) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq startp (getpoint "\nPick Start Point: ") ; Startpoint ; endp (getpoint "\nPick End Point: ") ; Endpoint ; openlst (list (list startp '(0 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)); coge el primero (el que más progresa) (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 (if (vl-some '(lambda(x) (not (equal (last x) 0.0 1e-3))) (setq path (get_path closelst))) (f3Dpol path Pathcol) (mk_lwp path) ) (alert "No path was found") ) (princ (strcat "\nExecution time:" (itoa (- (getvar 'MILLISECS) ti)) " milliseconds." ) ) (*error* nil) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS ;;;Create dictionary ;;;[Modified to consider all segments within any polyline] (defun addToDict (en / p1 p2 id clv i l c a) (setq i -1 id (cdr (assoc 5 (setq l (entget en)))) c (= (cdr (assoc 0 l)) "LINE") a 10) (while (setq p (if (and (setq i (1+ i)) c) (cdr (assoc (+ a i) l)) (vlax-curve-getPointAtParam en i))) (if (setq val (assoc (setq clv (strcat (itoa (fix (car p))) "-" (itoa (fix (cadr p))))) lstClvs)) (setq lstClvs (subst (append val (list (cons id i))) val lstClvs)) (setq lstClvs (cons (list clv (cons id i)) lstClvs)) ) ) ) ;;;return list cell (defun getCell (pt / clv v lr id p p0 pr par l c oc) (defun oc (c e i) (if c (cdr (assoc (+ i 10) l)) (vlax-curve-getPointAtParam e i))) (if (setq val (assoc (setq clv (strcat (itoa (fix (car pt))) "-" (itoa (fix (cadr pt))))) lstClvs)) (foreach par (cdr val) (setq e (handent (car par)) c (= (cdr (assoc 0 (setq l (entget e)))) "LINE")) (if (zerop (setq pr (cdr par))) (setq lr (cons (list (oc c e pr) (oc c e (1+ pr))) lr)) (setq lr (cons (list (oc c e (1- pr)) (setq p0 (oc c e pr))) lr) lr (if (setq p (oc c e (1+ pr))) (cons (list p0 p) lr) lr) ) ) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ; ;; 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 / lEdges edge pt fcost p1 p2 d temp) (setq pt (car node) fcost (caddr node) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;added By GLAVCVS (setq lEdges (getCell pt)) (foreach edge lEdges (setq p1 (car edge) p2 (cadr edge) d (distance p1 p2) temp nil ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (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 ((and (equal pt p1 1e-4) (not (memberfuzz p2 closelst))) (setq openlst (in_openlst (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp))) openlst)) ;;; (setq temp (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp)))) ) ((and (equal pt p2 1e-4) (not (memberfuzz p1 closelst))) (setq openlst (in_openlst (list p1 p2 (+ fcost d) (+ fcost d (distance p1 endp))) openlst)) ;;; (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 ; (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) lst)) ;Added by GLAVCVS (defun f3Dpol (pts c / doc ep ll la e x) (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)) ep (if (= 1 (getvar "CVPORT")) (vla-get-PaperSpace doc) (vla-get-ModelSpace doc)) ll (apply 'append pts) la (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length ll)))) (mapcar 'float ll)) e (vla-Add3DPoly ep la) x (vla-put-Color e c) ) ) ;; ; ;; 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) )

@nolex Give this quick modification a try: (defun c:foo (/ blx n nms s) ;; RJP » 2026-01-27 (cond ((setq s (ssget '((0 . "INSERT")))) (setq blx (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))) (foreach b (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (or (vl-position (setq n (vla-get-effectivename (vlax-ename->vla-object b))) nms) (vl-catch-all-apply 'vlax-put (list (vla-item blx n) 'explodable -1)) ) ) ) ) (princ) )

I don’t know which program can obtain the best equidistant centerline. But it shouldn’t be very different from what you can achieve with this code. ;********************************************************************** ;************************ G L A V C V S *************************** ;******* COMPLVRES • HORAS • VITAE • SVAE • IN • HOC • CODICE ******* ;***************** VT • TIBI • MAGNO • VSVI • SVIT ******************** ;********************************************************************** (defun c:CLG (/ PI/2 t/2 tol lst e1 e2 l1 l2 lp lp1 lp2 p0 p> p< r1? x m a ap =e1 ee c?1 pp+ c?2 NoEq lps lf lst lt pu *mU *pU *pB lSgmt *sombra* autoInt? ordenaPts interCpta ptEqd asr flanquea afina p>< pp px n lprs lpp lpr1 *pr1 p· ) (defun autoInt? (p1 p2 lp / p0 p1 p2);check if p1-p2 intersects lp list / autointerseccion? (vl-some '(lambda (p) (if p0 (inters p0 (setq p0 p) p1 p2) (not (setq p0 p)))) lp) ) (defun asr (pa pb p1 / ar ang ab); angle right/left ? / define el lado al que se encuentra el otro margen (cond ((< (abs (setq ang (- (setq ar (angle pa pb)) (setq ab (angle pb p1))))) PI) ang) (T (if (<= ar PI) (+ ar (- (* 2 PI) ab)) (- (- ar (* 2 PI)) ab))) ) ) (defun afina (lst / p0 p1 p2 s1 s2 pB lrr lar i pQbro p);this function gets break points on center-line / esta función obtiene los puntos de inflexion de la linea central (if (> (length lst) 3) (progn (foreach p lst (if p0 (if p1 (setq lar (cons (list (abs (asr p0 p1 p)) p0 p1 p (setq i (if i (1+ i) 0))) lar) p0 p1 p1 p) (setq p1 p) ) (setq p0 p) ) ) (setq lar (vl-sort lar '(lambda(a b) (> (car a) (car b)))) i -1) (if (or (= (length lar) 2) (> (car (nth 1 lar)) (* (car (nth 2 lar)) 5.))) (progn (if (= (abs (- (setq p1 (last (car lar))) (setq p2 (last (cadr lar))))) 1) (if (< p1 p2) (setq s1 (list (cadr (car lar)) (caddr (car lar))) s2 (list (caddr (cadr lar)) (cadddr (cadr lar)))) (setq s1 (list (cadr (cadr lar)) (caddr (cadr lar))) s2 (list (caddr (car lar)) (cadddr (car lar)))) ) ) (if (and s1 s2) (if (setq pQbro (inters (car s1) (cadr s1) (car s2) (cadr s2) nil)) (while (setq p (nth (setq i (1+ i)) lst)) (setq lrr (if (= i (max p1 p2)) (cons pQbro (cons p lrr)) (cons p lrr))) ) ) ) (simplifPts lrr 0.001) ) (simplifPts lst 0.001) ) ) lst ) ) (defun ordenaPts (lst pIni / p dm d ps? ps pa lr xx =a) ; sort list points / ordena los puntos (while lst (foreach p lst (if (and dm (/= (min (setq d (distance (if ps ps pIni) p)) dm) dm)) (if (or (not lr) (not pa) (< (abs (asr pa ps p)) (/ PI 2.)) ) (setq dm d ps? p) ) (if (not dm) (if pa (if (< (abs (asr pa ps p)) (/ PI 2.)) (setq dm (distance ps p) ps? p) ) (setq dm (distance (if ps ps pIni) p) ps? p) ) ) ) ) (if (setq =a (equal ps? pa 1e-4)) (setq lst (vl-remove ps? lst) ps? nil dm nil) (setq pa ps ps ps? ps? nil dm nil lst (vl-remove ps lst) lr (cons ps lr)) ) ) lr ) ;;; This function projects normals and angle bisectors to the other edge ;;; Esta función proyecta normales y bisectrices hasta el otro margen (defun interCpta (pM p1 p2 lp / i? fueraSombra? i1 i2 d p b x lpe); pM: mid point / pm: es el punto medio a emplear como base. (defun fueraSombra? (p); 'pcu': last 'closestpoint' successful / 'pcu' ES EL ULTIMO 'closest' EXITOSO (if (minusp (* (asr p (car *lpB) (car *lpU)) *sombra*)); if returned sign chamged to 'asr', came out of the shadows (*sombra*) / es decir, si cambió el signo devuelto por 'asr' entonces salimos de la sombra (setq *sombra* nil p (list p (car *lpU))) ) ) (defun i? (pA pB lp / p0 i dm is a) (foreach p lp (if p0 (if (setq i (inters p0 (setq p0 p) pA pB)) (if (and dm (/= (min (setq d (distance pM i)) dm) dm)) (if (not (autoInt? (polar pM (setq a (angle pM i)) 1e-3) (polar i (+ a PI) 1e-3) lpe)) (setq dm d is i) ) (if (and (not dm) (not (autoInt? (polar pM (setq a (angle pM i)) 1e-3) (polar i (+ a PI) 1e-3) lpe))) (setq dm (distance pm i) is i) ) ) ) ) (setq p0 p) ) (if is (list (car is) (cadr is) 0.0) ) ) (setq lpe (if (equal e e1) lp1 lp2)) (if (and pM p1 p2 (or (setq p (i? p1 p2 lp)) (not (autoInt? (setq pu (vlax-curve-getClosestPointTo ee pM)) (polar pM (angle pM pu) 1e-3) lpe)))) (list pM (if p p (setq *mU m *pB pM *sombra* nil *pU pu))); *pU: last closest point on another edge / RECUERDA QUE *pU ES EL PUNTO CLOSETEADO ULTIMO EN EL OTRO MARGEN (if *sombra* (fueraSombra? pM) (if *pU; *pU SOLO SE CARGÓ CUANDO EL RESTO DE OPCIONES (normales y bisectriz) NO FUNCIONARON (if (autoInt? (setq x (if *lpU (car *lpU) *pU)) (polar pM (angle pM x) 1e-3) lpe);|If it also self-intecsects when searching for the last sucessfully closest point|; ;|SI TAMBIÉN SE AUTOINTERSECA AL BUSCAR EL ÚLTIMO PUNTO 'CLOSETEADO' EXITOSAMENTE|; (setq *sombra* (if (= (abs (- m *mU)) 1) (asr pM *pB *pU)) *lpU (cons *pU *lpU) *lpB (cons *pB *lpB) p nil) (if *lpU (list pM (car *lpU))) ) (alert "EXCEPTION!") ) ) ) ) (defun ptEqd (A B e1 e2 / eqDistf t0 t1 f0 f1 tm fm n i v+- v*); get eqdist point / captura punto equidistante (defun v+- (o a b) (mapcar o a b)) (defun v* (p s) (mapcar '(lambda (x) (* x s)) p)) (defun eqDistf (ds A B e1 e2 / pt d1 d2 p1) (setq pt (v+- '+ A (v* (v+- '- B A) ds)) d1 (distance pt (setq p1 (vlax-curve-getClosestPointTo e1 pt))) d2 (distance pt (vlax-curve-getClosestPointTo e2 pt)) *pr1 (vlax-curve-getParamAtPoint e1 p1) ) (- d1 d2) ) (setq t0 0.0 t1 1.0) (while (and (< (setq n (if n (1+ n) 0)) 100) (> (- t1 t0) 1e-6));bisection method/método de bisección (setq tm (/ (+ t0 t1) 2.0) fm (eqDistf tm A B e1 e2) ) (if (< (abs fm) 1e-9) (setq n 100 t1 tm t0 tm) (if (< (* (if f0 f0 (eqDistf t0 A B e1 e2)) fm) 0.0) (setq t1 tm f1 fm) (setq t0 tm f0 fm) ) ) ) (if (< t1 1.0) ; final parameter and eqdist point / parámetro final y punto equidistante (v+- '+ A (v* (v+- '- B A) (/ (+ t0 t1) 2.0))) ) ) (defun simplifPts (lst tol / po p0 p1 p> p a lr le np x);simplify list point / simplifica la lista de puntos (foreach p lst (if p0 (if p1 (if (setq po (inters p0 (polar p0 (setq a (angle p0 p1)) 1) p (polar p (+ a (/ pi 2)) 1) nil)) (if (> (distance po p) tol) (setq le (cons p1 le) p0 p1 p1 p x (if x (1+ x) 2) ) ; including point / si hay que incluir el punto (setq p1 p);deleting point/si hay que suprimirlo ) ) (setq p1 p) ) (setq p0 p le (cons p le)) ) (if (equal p (last lst) 1e-4) (setq le (cons p le))) ) le ) (defun flanquea (p0 p tol / pM px pEqd a d); It obtain points for the agreement between segments according tolerance / Obtiene los puntos para acuerdo de segmentos respetando tolerancia (setq pM (list (/ (+ (car p0) (car p)) 2.) (/ (+ (cadr p0) (cadr p)) 2.)) pEqd (ptEqd (setq pA (polar pM (setq a (+ (angle p0 p) (/ PI 2.))) 50)) (setq pB (polar pM (+ a PI) 50)) e1 e2) ) (if (> (distance pEqd pM) tol) (progn (setq lf (cons pEqd lf));saving / guardamos (if (not (member *pr1 lpr1)) (setq lpr1 (cons *pr1 lpr1))) (flanquea p0 pEqd tol) (flanquea p pEqd tol) ) ) (append lf (list p0 p)) ) (vl-catch-all-apply '(lambda() (if (and (setq e1 (car (entsel "\nSelect FIRST LWPolyline..."))) (= (cdr (assoc 0 (setq l1 (entget e1)))) "LWPOLYLINE") ) (if (and (setq e2 (car (entsel "\nSelect SECOND LWPolyline..."))) (= (cdr (assoc 0 (setq l2 (entget e2)))) "LWPOLYLINE") ) (progn (foreach l l1 (if (= (car l) 10) (setq lp1 (cons (cdr l) lp1)))) (foreach l l2 (if (= (car l) 10) (setq lp2 (cons (cdr l) lp2)))) (if (setq c?1 (= (rem (cdr (assoc 70 l1)) 2) 1)) (setq lp1 (cons (last lp1) lp1)) (setq c?1 (equal (car lp1) (last lp1) 1e-4)) ) (if (setq c?2 (= (rem (cdr (assoc 70 l2)) 2) 1)) (setq lp2 (cons (last lp2) lp2)) (setq c?2 (equal (car lp2) (last lp2) 1e-4)) ) (if (not c?1) (setq r1? (> (distance (car lp1) (car lp2)) (distance (car lp1) (last lp2))))) (setq tol (getreal "\nMaximum tolerance for equidistance within segments <0.005> : ") ; tolerance adjust / AJUSTAR TOLERANCIA AQUI tol (if tol tol 0.005) PI/2 (/ PI 2.) lp1 (if r1? (reverse lp1) lp1) t/2 (/ tol 2.) *lpB nil *lpU nil ) (foreach e (list e1 e2) (setq p0 nil m nil r? (if (setq =e1 (equal e e1)) r1?) lp (if =e1 lp2 lp1) c? (if =e1 c?1 c?2) ee (if =e1 e2 e1)) (while (setq p (vlax-curve-getPointAtParam e (setq m (if m ((if r? 1- 1+) m) (if r? (vlax-curve-getEndParam e) 0))))) (setq pu nil n1 nil n2 nil n3 nil) (if p0 (progn (setq lAB (interCpta p (polar p (setq a (+ (angle p0 p) PI/2)) 1e6) (polar p (+ a PI) 1e6) lp); normal at the begining of the segment / NORMAL AL COMIENZO DEL SEGMENTO lst (if lAB (cons (setq n1 (ptEqd (car lAB) (cadr lAB) e1 e2)) lst) lst) ) (if (setq p> (vlax-curve-getPointAtParam e ((if r? 1- 1+) m))); (setq lAB (interCpta p (polar p (setq a (/ (+ (angle p p0) (angle p p>)) 2.)) 1e6) (polar p (+ a PI) 1e6) lp); bisector / Bisectriz lst (if lAB (cons (setq n2 (ptEqd (car lAB) (cadr lAB) e1 e2)) lst) lst) lAB (interCpta p (polar p (setq a (+ (angle p p>) PI/2)) 1e6) (polar p (+ a PI) 1e6) lp); normal at the ending of the segment / NORMAL AL FINAL DEL SEGMENTO lst (if lAB (cons (setq n3 (ptEqd (car lAB) (cadr lAB) e1 e2)) lst) lst) ) ) (setq p< p0 p0 p) ) (if (setq p> (vlax-curve-getPointAtParam e ((if r? 1- 1+) m))) (progn (setq lAB (interCpta p (polar (setq p0 p) (setq a (+ (angle p0 p>) PI/2)) 1e6) (polar p0 (+ a PI) 1e6) lp);normal at the begining of the segment / NORMAL AL COMIENZO DEL SEGMENTO lst (if lAB (cons (setq n1 (ptEqd (car lAB) (cadr lAB) e1 e2)) lst) lst) ) (if c? (setq lAB (interCpta p (polar p (setq a (/ (+ (angle p (vlax-curve-getPointAtParam e (1- (vlax-curve-getEndParam e)))) (angle p p>)) 2.)) 1e6) (polar p (+ a PI) 1e6) lp ) lst (if lAB (cons (setq n2 (ptEqd (car lAB) (cadr lAB) e1 e2)) lst) lst) ) ) ) ) ) ) ) (setq lst (cdr (simplifPts (reverse (ordenaPts lst (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (car lp1) (car lp2)))) 0.001)) p0 nil n -1) (if (and c?1 c?2) (setq lst (cons (last lst) lst))) (while (setq p (nth (setq n (1+ n)) lst)) (if p0 (if (or (and pa (setq pp (nth (1+ n) lst)) (setq p>< (inters pa p0 p pp nil)); intecsections of extensions / intersección de las prolongaciones (setq px (inters p0 p p>< (polar p>< (+ (angle p0 p) (/ pi 2)) 1) nil)); distance to the base segment / distancia al segmento base (> (distance p>< px) tol); separation greather than tolerance / si la separacion es superior a la tolerancia ) (and c?1 c?2) ) (setq pM (list (/ (+ (car p0) (car p)) 2.) (/ (+ (cadr p0) (cadr p)) 2.)) NoEq (> (setq df (/ (abs (- (distance pM (vlax-curve-getClosestPointTo e1 pM)) (distance pM (vlax-curve-getClosestPointTo e2 pM)))) 2.)) t/2) pp+ (if NoEq (if (< df tol) (if (setq p· (ptEqd (polar pM (setq a (+ (angle p0 p) PI/2)) 5) (polar pM (+ a PI) 5) e1 e2)) (progn (if (not (member *pr1 lpr1)) (setq lpr1 (cons *pr1 lpr1))) (list p0 p· p) ) ) (afina (ordenaPts (flanquea p0 p t/2) p0)) ) ) lf nil ) (setq pp+ nil) ) ) (setq lt (if p0 (cons p0 lt) lt) pa p0 p0 p ap a) (if pp+ (foreach v (reverse (cdr (reverse (cdr pp+)))) (setq lt (cons v lt)))) ) (setq lt (ordenaPts (simplifPts lt 0.001) p0)) (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(8 . "0") '(100 . "AcDbPolyline") (cons 90 (length lt)) ) (foreach p lt (setq lps (cons (list 10 (car p) (cadr p)) lps)))) ) (if (or c?1 c?2) (entmod (append (entget (entlast)) '((70 . 1))))) ) ) ) ) ) (princ) ) It is an improvement over the last code I posted. However, I have abandoned this variant because, as you rightly pointed out in your previous post, it doesn’t work in some of your drawings, and fixing it turns out to be more complicated than is reasonably justified. Also, as I mentioned before, this approach is more brute-force and slower. Still, it is useful to illustrate what can be done in drawings like this. For that reason, I decided to publish it now. In my opinion, the best equidistant centerline should achieve everything that is possible and bound what is impossible within a tolerance. What is possible: Vertices: – all points or vertices of the centerline can and therefore must be equidistant. Segments: – all centerline segments that result from the overlap of segments on both margins (80/90%) must also be equidistant along their entire length. What is impossible: Segments: – the interior of segments that do not meet the previous condition cannot be geometrically equidistant, BUT their maximum “non-equidistance” should be bounded by a tolerance. Based on these criteria, for polylines representing linear entities such as rivers, roads, etc., this code should for tolerances down to 1 millimeter (the smaller the tolerance, the larger the resulting time&geometry).

We talk a lot about speed but does it matter, if it take seconds or a minute, a task I worked on could take up to 3 hours manually it takes 2 minutes now. I improved the speed 3 times by recoding. Yes if have thousands of lines go get a coffee. still faster than having a go manually. I guess what I am saying are we talking seconds, minutes or hours ? 13 seconds for 5000, I would call that fantastic. If worried about time add a progress bar it's a Acet function. The task above started at like 25 minutes to do, so 2 minutes as final version is considered acceptable by me. Yes talking thousands of changes.

As @Steven P suggested you can have as many plot predefined settings as you want. Did you test the "getpropertyvalue" code in your LT as per my request above. I don't have LT so can not test.

I think code can be made easier, yes LT does support VL just not a full set but should support "getattributes" an easier way of getting attribute values or you may be able to use the getpropertyvalue method even easier. Have a look at Lee-mac ssget functions. you should use "E" to select block. https://www.lee-mac.com/ssget.html If the desired result is to plot ";; 6. Launch Plot Command" say a PDF with a known filename please say so, no need for a clipboard. There are plenty of plot lisps out there. You need to provide more details, is the title block true size or scaled, what device for output, PDF, A3, A1, plotter names and so on. Is it in model or a layout ? A couple of test code just try them. Property would be easiest, please let me know if it works in LT. (DEFUN C:test ( / ) (setq ent (car (entsel "\npick block "))) (setq dwgno (strcase (getpropertyvalue ent "DRAWING_NO.") T))) (princ) ) ; Wrapper the entsel in a while is it a BLOCK with attributes so if wrong pick do again. A enter check would be exit. ; in this test looks for one attribute but can redo as look for multiple atts and save value in varaibles. (defun c:test ( / ) (setq obj (vlax-ename->vla-object (car (entsel "\nPick block with attributes ")))) (setq atts (vlax-invoke obj 'Getattributes)) (vlax-for att atts (if (= (vlax-get att 'textstring) "DRAWING_NO.") (setq dwgno (strcase (getpropertyvalue ent "DRAWING_NO.") T))) ) ) (princ) )

I've finished with "lw_orth.lsp"... Take it, or leave it... It's up to you OP... I've found some lacks in latest updates - in 3d with ucs aligned in 3d with lwpolylines (grread-mult) versions produced unwanted behaviour... Hopefully now fixed... Also, added (vl-cmdf "_.undo" "_m") as first line at each command function, so upon finished execution, you can just use UNDO (Back) to return before running command... There was 5 downloads till I reattached fixed version... Sorry for inconvenience - it happens from time to time... Regards, M.R. orthogonalize_lwpolyline-ucs3D.dwg lw_orth.lsp

I took a look at your modifications to make the code more robust I have to say that I didn’t think it would be possible to consider the presence of “splines” in the drawing. But I agree with including this filter in the current code. As for the filters for “legacy” POLYLINEs and LWPOLYLINEs, the code wouldn’t need those filters if we accept the premise that only straight distances between points will be measured. BUT: to also cover this possibility, I’ve introduced a new function and made some modifications that allow any “*LINE” to be included in the analysis (including any “POLYLINE” or “SPLINE”). In this way, the filters for the selection set become, once again, much simpler. This also allows the drawing to compute routes using curved linear objects (arcs are excluded for now). Regarding the use of LM:rtos, I consider this optional for cases where small cells are desired, and this may introduce some drawbacks. Moreover, using such small cells significantly harms execution speed. I ran a comparison between the execution speed of your code and this new one I’m attaching, and yours is 3 x slower. Additionally, creating the matrix with your requirements is also quite slow. ;; 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. ; ;; ; ;| Added or revised code by GLAVCVS (january 2026) -All set are grouped into one -An associative sparse matrix cell->handles is created for faster cell querying (using new 'addToDict' and 'getCell' functions) -The "edges" list is replaced with the local search retourned by 'getCell' T E S T S ===== fas: 4-5 x faster than previous fas lsp: 7-8 x faster than previous lsp (february 8, 2026): -Added new function '·dist·' for measuring distances of curved segments -Added a new lightweight function 'glvFix' to prevent possible rounding mismatches -Several modifications to include in filters and matrix the necessary compatibility with curved linear objects |; (defun c:A** (/ *error* addToDict getCell upd_openlst in_openlst get_path memberfuzz mk_lwp f3Dpol LM:rtos set_errhandler sspl i startp endp e openlst closelst found acdoc lstClvs Pathlay Pathcol Pathlwt varl node ti ·dist· glvFix ) (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com)) (defun *error* (msg) (if e (if command-s (command-s "_.draworder" e "" "_f") (vl-cmdf "_.draworder" e "" "_f") ) ) (mapcar (function eval) varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (vla-endundomark acdoc) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS ;;;Create dictionary (defun addToDict (en / p val id clv i l c a) (setq i -1 id (cdr (assoc 5 (setq l (entget en)))) c (= (cdr (assoc 0 l)) "LINE") a 10) (while (setq p (if (and (setq i (1+ i)) c) (cdr (assoc (+ a i) l)) (vlax-curve-getPointAtParam en i))) (if (setq val (assoc (setq clv (strcat (itoa (glvFix (car p) 0.0001)) "," (itoa (glvFix (cadr p) 0.0001)) "," (itoa (glvFix (caddr p) 0.0001)))) lstClvs)) ;(setq val (assoc (setq clv (strcat (LM:rtos (car p) 2 4) "," (LM:rtos (cadr p) 2 4) "," (LM:rtos (caddr p) 2 4))) lstClvs)) (setq lstClvs (subst (append val (list (cons id i))) val lstClvs)) (setq lstClvs (cons (list clv (cons id i)) lstClvs)) ) ) ) (defun ·dist· (l? e p1 p2) (if l? (vlax-curve-getEndParam e) (abs (- (vlax-curve-getDistAtParam e p1) (vlax-curve-getDistAtParam e p2))))) ;;;return list cell ;;*** Modified to access the new dictionary format *** (defun getCell (pt / val clv lr pr par l c oc p0 p) (defun oc (c e i) (if c (cdr (assoc (+ i 10) l)) (vlax-curve-getPointAtParam e i))) (if (setq val (assoc (setq clv (strcat (itoa (glvFix (car pt) 0.0001)) "," (itoa (glvFix (cadr pt) 0.0001)) "," (itoa (glvFix (caddr pt) 0.0001)))) lstClvs)) (foreach par (cdr val) (setq e (handent (car par)) c (= (cdr (assoc 0 (setq l (entget e)))) "LINE")) (if (zerop (setq pr (cdr par))) (setq lr (cons (list c e pr (1+ pr)) lr)) (setq lr (cons (list c e (1- pr) pr) lr) lr (if (vlax-curve-getPointAtParam e (1+ pr)) (cons (list c e pr (1+ pr)) lr) lr) ) ) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ; ;; 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 (node endp openlst closelst / lEdges pt fcost p1 p2 d l? temp) (setq pt (car node) fcost (caddr node) ) (setq lEdges (getCell pt)) (foreach edge lEdges (setq l? (car edge);new e (cadr edge);new pr1 (caddr edge);new pr2 (cadddr edge);new p1 (vlax-curve-getPointAtParam e pr1);new p2 (if l? (vlax-curve-getEndPoint e) (vlax-curve-getPointAtParam e pr2));new d (·dist· l? e pr1 pr2);new temp nil ) (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)) ) ) (vl-sort openlst (function (lambda (a b) (< (cadddr a) (cadddr b))))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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)))) ) ) ;; ; ;; 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 ) ;; ; ;; f3Dpol ; ;; ; ;; Draw an 3dpolyline given a point list ; ;; ; ;; Will be drawn on layer, lineweight and color defined by Variables ; ;; at beginning of program. ; ;; ; ;;;ADDED by GLAVCVS (defun f3Dpol (pts c / ep ll la e) (setq ep (if (= 1 (getvar (quote cvport))) (vla-get-PaperSpace acdoc) (vla-get-ModelSpace acdoc)) ll (apply (function append) pts) la (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length ll)))) (mapcar (function float) ll)) e (vla-Add3DPoly ep la) ) (vla-put-Color e c) (vla-put-Layer e Pathlay) (vla-put-Lineweight e Pathlwt) (vlax-vla-object->ename e) ) ;; ; ;; 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 (* 128 (getvar (quote plinegen)))) (cons 370 Pathlwt) ) (mapcar (function (lambda (a) (cons 10 a))) pl) ) ) ) (defun glvFix (r i / f f1) (if (= (setq f (fix r)) (setq f1 (fix (+ r i)))) f f1)) ;; A wrapper for the rtos function to negate the effect of DIMZIN - Lee Mac (defun LM:rtos (real units prec / dimzin result) (setq dimzin (getvar (quote dimzin))) (setvar (quote dimzin) 0) (setq result (vl-catch-all-apply (function rtos) (list real units prec))) (setvar (quote dimzin) dimzin) (if (not (vl-catch-all-error-p result)) result ) ) ;; Error Handler by Elpanov Evgenyi ; (defun set_errhandler (l) (setq varl (mapcar (function (lambda (a) (list (quote setvar) a (getvar a)))) l)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Change values of following 3 variables to suit your need. ; (setq Pathlay "0" Pathcol 3 ; 1=Red 2=Yellow 3=Green etc. ; Pathlwt 30 ; lineweight for path 0.3 mm ; ) (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))) (set_errhandler (list "clayer" "osmode" "cmdecho")) (setvar (quote cmdecho) 0) (setvar (quote osmode) 1) (setvar (quote lwdisplay) 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (prompt "\nSelect LINE and polygonal POLYLINE network entities...") (if (setq sspl (ssget '((0 . "*LINE")))) (foreach en (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex sspl))) (addToDict en) ) ) (initget 1) (setq startp (getpoint "\nPick or specify Start Point : ")) (initget 1) (setq endp (getpoint "\nPick or specify End Point : ")) (setq openlst (list (list startp (list 0.0 0.0 0.0) 0.0 (distance startp endp)))) (vla-startundomark acdoc) (setq ti (getvar (quote 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 node endp (cdr openlst) closelst)) ) ) (if found (if (vl-some (function (lambda (x) (not (equal (last x) 0.0 1e-4)))) (setq path (get_path closelst))) (setq e (f3Dpol path Pathcol)) (setq e (mk_lwp path)) ) (alert "No path was found...") ) (princ (strcat "\nExecution time : " (itoa (- (getvar (quote millisecs)) ti)) " milliseconds...")) (*error* nil) ) In any case, I haven’t tested the code thoroughly enough on drawings containing “splines” or other complex linear objects. In addition, there may be some situations that may not be covered. But it should work. In any case, the code is open to any improvements anyone may want to make. Best regards.

The path found has to travel on edges not on points. If your graph does not have edges on the diagonal of the nodes it cannot find that path. ymg

I must apologize for forgetting to reply to your comment. Please forgive me for this. Welcome to the forum. Yes, that's right. In the case of that drawing, the code doesn't return the shortest path. Perhaps it's a limitation of A* for drawings like this. I think @ymg3 is the most qualified to answer this.

Not sure if OP is still online, but IMHO, I think this update is better... (defun c:lw_orth ( / un f p lw lwx pl cl ) (defun un ( l / a ll ) (while (setq a (car l)) (if (vl-some (function (lambda ( x ) (equal x a 1e-10))) l) (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a 1e-10))) (cdr l))) (setq ll (cons a ll) l (cdr l)) ) ) (reverse ll) ) (defun f ( l / i p1 p2 px r ) (if (> (length l) 2) (progn (setq i -1) (while (< (setq i (1+ i)) (1- (length l))) (if (not p1) (setq p1 (nth i l) p2 (nth (1+ i) l)) (setq p1 p2 p2 (nth (1+ i) l)) ) (if (= i 0) (setq r (cons (car l) r)) ) (setq r (cons (if (setq px (p p1 p2 p2)) (setq p2 px) p2) r)) (if (= i (- (length l) 2)) (setq r (cons (last l) r)) ) ) (setq r (reverse r)) (un (apply (function append) (mapcar (function (lambda ( p1 p2 / pp ) (if (setq pp (vl-some (function (lambda ( x ) (if (and (equal (distance p1 p2) (+ (distance p1 x) (distance x p2)) 1e-10) (not (equal x p1 1e-10)) (not (equal x p2 1e-10))) x))) l)) (list p1 pp) (list p1)))) r (append (cdr r) (list (car r)))))) ) ) ) (defun p ( p1 p2 p3 / p21 p22 ) (setq p21 (inters p1 (polar p1 (* 0.5 pi) 1.0) p3 (polar p3 0.0 1.0) nil)) (setq p22 (inters p1 (polar p1 0.0 1.0) p3 (polar p3 (* 0.5 pi) 1.0) nil)) (if (< (distance p2 p21) (distance p2 p22)) p21 p22 ) ) (if (and (setq lw (car (entsel "\nPick polygonal lwpolyline to make its clone orthogonalized..."))) (= (cdr (assoc 0 (setq lwx (entget lw)))) "LWPOLYLINE") (vl-every (function (lambda ( x ) (= (cdr x) 0.0))) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) lwx)) ) (progn (if (or (= (cdr (assoc 70 lwx)) 1) (= (cdr (assoc 70 lwx)) 129)) (setq cl t) ) (setq pl (mapcar (function (lambda ( p ) (trans p lw 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))) (if cl (setq pl (append pl (list (car pl)))) ) (if (> (length pl) 2) (entmake (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length (setq pl (f pl)))) (cons 70 (if cl (1+ (* 128 (getvar (quote plinegen)))) (* 128 (getvar (quote plinegen))))) (assoc 38 lwx) ) (mapcar (function (lambda ( x ) (cons 10 x))) (mapcar (function (lambda ( p ) (trans p 1 lw))) pl)) (list (cons 62 3) (assoc 210 lwx) ) ) ) (prompt "\nPicked lwpolyline with insufficient number of vertices...") ) ) (prompt "\nMissed, or picked entity not polygonal lwpolyline... Better luck next time...") ) (princ) ) (defun c:lw_orth-grread ( / un f p lw lwx pl ppl cl lwn lwnx gr pp pre suf ) (defun un ( l / a ll ) (while (setq a (car l)) (if (vl-some (function (lambda ( x ) (equal x a 1e-10))) l) (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a 1e-10))) (cdr l))) (setq ll (cons a ll) l (cdr l)) ) ) (reverse ll) ) (defun f ( l / i p1 p2 px r ) (if (> (length l) 2) (progn (setq i -1) (while (< (setq i (1+ i)) (1- (length l))) (if (not p1) (setq p1 (nth i l) p2 (nth (1+ i) l)) (setq p1 p2 p2 (nth (1+ i) l)) ) (if (= i 0) (setq r (cons (car l) r)) ) (setq r (cons (if (setq px (p p1 p2 p2)) (setq p2 px) p2) r)) (if (= i (- (length l) 2)) (setq r (cons (last l) r)) ) ) (setq r (reverse r)) (un (apply (function append) (mapcar (function (lambda ( p1 p2 / pp ) (if (setq pp (vl-some (function (lambda ( x ) (if (and (equal (distance p1 p2) (+ (distance p1 x) (distance x p2)) 1e-10) (not (equal x p1 1e-10)) (not (equal x p2 1e-10))) x))) l)) (list p1 pp) (list p1)))) r (append (cdr r) (list (car r)))))) ) ) ) (defun p ( p1 p2 p3 / p21 p22 ) (setq p21 (inters p1 (polar p1 (* 0.5 pi) 1.0) p3 (polar p3 0.0 1.0) nil)) (setq p22 (inters p1 (polar p1 0.0 1.0) p3 (polar p3 (* 0.5 pi) 1.0) nil)) (if (< (distance p2 p21) (distance p2 p22)) p21 p22 ) ) (if (and (setq lw (car (entsel "\nPick polygonal lwpolyline to make its clone orthogonalized..."))) (= (cdr (assoc 0 (setq lwx (entget lw)))) "LWPOLYLINE") (vl-every (function (lambda ( x ) (= (cdr x) 0.0))) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) lwx)) ) (progn (if (or (= (cdr (assoc 70 lwx)) 1) (= (cdr (assoc 70 lwx)) 129)) (setq cl t) ) (setq pl (mapcar (function (lambda ( p ) (trans p lw 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))) (if cl (setq pl (append pl (list (car pl)))) ) (if (> (length pl) 2) (setq lwn (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length (setq ppl (f pl)))) (cons 70 (if cl (1+ (* 128 (getvar (quote plinegen)))) (* 128 (getvar (quote plinegen))))) (assoc 38 lwx) ) (mapcar (function (lambda ( x ) (cons 10 x))) (mapcar (function (lambda ( p ) (trans p 1 lw))) ppl)) (list (cons 62 3) (assoc 210 lwx) ) ) ) ) (prompt "\nPicked lwpolyline with insufficient number of vertices...") ) (vl-cmdf "_.ucs" "_m" (mapcar (function +) (list 0.0 0.0) (getvar (quote viewctr)))) (if (and lwn (setq lwnx (entget lwn)) (setq pre (reverse (member (assoc 39 lwnx) (reverse lwnx)))) (setq suf (list (assoc 210 lwnx)))) (while (= (car (setq gr (grread t))) 5) (setq pp (cadr gr)) (vl-cmdf "_.ucs" "_3p" "_non" (list 0.0 0.0) "_non" pp "") (setq pl (mapcar (function (lambda ( p ) (trans p lw 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))) (if cl (setq pl (append pl (list (car pl)))) ) (setq pre (subst (cons 90 (length (setq ppl (f pl)))) (assoc 90 pre) pre)) (entupd (cdr (assoc -1 (entmod (append pre (mapcar (function (lambda ( x ) (cons 10 x))) (mapcar (function (lambda ( p ) (trans p 1 lw))) ppl)) suf))))) ) ) ) (prompt "\nMissed, or picked entity not polygonal lwpolyline... Better luck next time...") ) (princ) ) BTW. As addition to previous version, now there is (grread) implementation... (grsnap) is here unnecessary... HTH. Regards, M.R.

You can try changing the tolerance to simplify the result. However, the result will be different from what you get with dexus or GP_ codes because mine is designed so that any point on the center line is equidistant and the interior of the segments never exceeds the user-defined tolerance.

Code updated above ... give it a try!

I did see a for-purchase program that used a raster image and maybe worked with QGIS, I'll see if I can find it again, the demo video looked pretty good and even split around islands, side branches, etc.. It had a lot of parameters to fill out in a window for what to grab, so still a good bit of work, IIRC.

You could use this to rename the reference in question so that it references a different (duplicate) block definition, which could then be marked as explodable.

Something like this? (defun c:foo (/ d e el m p1 p2) (cond ((and (setq e (car (entsel "\nPick dimension: "))) (vlax-property-available-p (vlax-ename->vla-object e) 'measurement) (setq d (vla-get-measurement (vlax-ename->vla-object e))) (progn (vlax-for a (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (cdr (assoc 2 (entget e))) ) (and (= "AcDbMText" (vla-get-objectname a)) (setq m (vlax-vla-object->ename a))) ) m ) (setq p1 (cdr (assoc 10 (setq el (entget m))))) (setq p2 (getpoint p1 "\nSpecify second point: ")) ) (setq e (entmakex (append (vl-remove-if '(lambda (x) (= 330 (car x))) el) (list (cons 10 p2)))) ) (vla-put-textstring (setq e (vlax-ename->vla-object e)) (vl-princ-to-string (* 0.001 d))) (vla-put-rotation e 0.) ) ) (princ) )

Trash5.dwgTrash4.dwgTrash3.dwgTrash2.dwgTrash1.dwg I opened your files in Bricscad and did WBLOCK on them, and they all reduced down in size dramatically. I haven't looked to see if anything is missing, so have a look and see if they are OK. The last file I Wblocked complained that there were over 1,500 layer filters. I don't use them myself, but it seems excessive to me (see screenshot file).

It's difficult to know what's happening there without the original drawing and without knowing the starting and ending points. I reproduced that drawing from your image and ran the code without any problems. But perhaps I'm wrong. PS: Anyway, try your code on this drawing (mine will return the same result because it only speeds up the process). YMG3.dwg I've left a yellow line on a different layer from the rest so that it's outside the selection set, and the start and end points are marked with little circles.

Hi I've attached a small revision of @ymg3's excellent code that further improves speed. Tested on this drawing (3200 polylines) Ax.dwg ;; 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. ; ;; ; ;| Added or revised code by GLAVCVS (january 2026) -All set are grouped into one -An associative sparse matrix cell->handles is created for faster cell querying (using new 'addToDict' and 'getCell' functions) -The "edges" list is replaced with the local search retourned by 'getCell' T E S T S ===== fas: 4-5 x faster than previous fas lsp: 7-8 x faster than previous lsp |; (defun c:A* (/ sspl i edges startp endp openlst closelst found acdoc Edgelay Pathlay Pathcol Pathlwt lstClvs ) (vl-load-com) ; Changes values of following 4 global variables to suit your need. ; (setq Edgelay "0" Pathlay "0" 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)) ;;; (addToDict en) ;;; (setq edges (append edges (mk_edge (listpol2d en)))) ;;; ) ;;; nil ;;; ) ;;; ;;; (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 ;;; ) ;;; ) ;;; ) ;;; ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS (if (setq sspl (ssget "X" (list '(0 . "*LINE") (cons 8 EdgeLay)))) (foreach en (mapcar (function cadr) (ssnamex sspl)) (addToDict en) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS ;;;Create dictionary (defun addToDict (en / p1 p2 id clv) (setq p1 (vlax-curve-getStartPoint en) p2 (vlax-curve-getEndPoint en) id (cdr (assoc 5 (entget en))) ) (foreach p (list p1 p2) (if (setq val (assoc (setq clv (strcat (itoa (fix (car p))) "-" (itoa (fix (cadr p))))) lstClvs)) (setq lstClvs (subst (append val (list id)) val lstClvs)) (setq lstClvs (cons (list clv id) lstClvs)) ) ) ) ;;;return list cell (defun getCell (pt / clv v lr) (if (setq val (assoc (setq clv (strcat (itoa (fix (car pt))) "-" (itoa (fix (cadr pt))))) lstClvs)) (foreach e (cdr val) (setq lr (cons (list (butlast (vlax-curve-getStartPoint (handent e))) (butlast (vlax-curve-getEndPoint (handent e)))) lr)) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ; ;; 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 / lEdges edge pt fcost p1 p2 d temp) (setq pt (car node) fcost (caddr node) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;added By GLAVCVS (setq lEdges (getCell pt)) (foreach edge lEdges (setq p1 (car edge) p2 (cadr edge) d (distance p1 p2) temp nil ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (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 ; (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) )

Trying to find it again. Give this a try. You pick points in sequence it will draw offsets, make sure you press Enter to finish picking points as it will fillet all the offset segments. offset sides pline.lsp

Here is a boiled down simple version with no error testing. It assumes that the dimensions will run on the same angle as the angle between the point and the curve segment: ;; Created by P. Kenewell 1/22/2026 (defun c:dim2pts (/ ep i p1 p2 p3 ss) (if (and (progn (princ "\nSelect Points to Dimension: ") (setq ss (ssget '((0 . "POINT,INSERT")))) ) (setq ep (entsel "\nSelect a curve to Dimension to: ")) ) (repeat (setq i (sslength ss)) (setq p1 (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) p2 (vlax-curve-getclosestpointto (vlax-ename->vla-object (car ep)) p1) p3 (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)) ) (command "._dimrotated" (* (/ (angle p1 p2) pi) 180.0) "_non" p1 "_non" p2 "_non" p3) ) ) (princ) ) Example Screenshots:

(if (= (minusp botLength) T) ;; verifies that a number is negative (setq botLength 0) ;; if it is, it will set to 0 (setq botLength (- botLength 6000)) ;; if it isn't, it will be substracted with "6000" )

You mean like this? (if (minusp botLength) 0 (- botLength 6000))

"Modelspace, paperspace or both?" looks like @Chicane_Apex has left the building, just like Elvis.

Another very useful is "Entmake functions.lsp", it has various entmake functions in it. Maybe make a word doc etc of your functions describing what they do. We had a "how to directory" with lots of help files. Was thinking about doing macros in Notepad++ run ents, run ss, ssl for layer, ssi for insert and so on. This is a common one. (repeat (setq x (sslength ss)) (setq obj (vlax-ename->vla-object (ssname ss (setq x (- x 1))))) ) Posted this before. Lisp files Apr 2024.docx

Best way to clean a difficult file is WBlock, not sure what had those bloated like that.

I WBlocked them. new Lines and arcs.dwg new font.dwg

@Danielm103 How can AI be better than human revision? Here is AI - I've added "red" color... (defun c:ortho_pline ( / orthogonalize-points edata ent newpts p pl pts x) (defun orthogonalize-points (pts / dx-in dx-out dy-in dy-out i in-is-h new-x new-y out-is-h p0 p1 p2 result) ;; If fewer than 3 points, nothing to do (if (< (length pts) 3) pts (progn (setq result pts) ;; Iterate interior vertices (setq i 1) (while (< i (- (length pts) 1)) (setq p0 (nth (- i 1) result)) (setq p1 (nth i result)) (setq p2 (nth (+ i 1) result)) ;; Incoming vector p0 -> p1 (setq dx-in (- (car p1) (car p0))) (setq dy-in (- (cadr p1) (cadr p0))) ;; Outgoing vector p1 -> p2 (setq dx-out (- (car p2) (car p1))) (setq dy-out (- (cadr p2) (cadr p1))) ;; Dominant direction tests (setq in-is-h (>= (abs dx-in) (abs dy-in))) (setq out-is-h (>= (abs dx-out) (abs dy-out))) ;; Case 1: Proper corner (one horizontal, one vertical) (cond ((/= in-is-h out-is-h) (if in-is-h (progn ;; incoming horizontal, outgoing vertical (setq new-x (car p2)) (setq new-y (cadr p0)) ) (progn ;; incoming vertical, outgoing horizontal (setq new-x (car p0)) (setq new-y (cadr p2)) ) ) ) ;; Case 2: both horizontal (in-is-h (setq new-x (car p1)) (setq new-y (cadr p0)) ) ;; Case 3: both vertical (t (setq new-x (car p0)) (setq new-y (cadr p1)) ) ) ;; Replace interior point (setq result (subst (list new-x new-y) p1 result)) (setq i (1+ i)) ) result ) ) ) (setq ent (car (entsel "\nSelect a polyline: "))) (if (not ent) (progn (princ "\nNothing selected.") (exit) ) ) (setq edata (entget ent)) ;; Ensure LWPOLYLINE (if (/= (cdr (assoc 0 edata)) "LWPOLYLINE") (progn (princ "\nEntity is not a lightweight polyline.") (exit) ) ) ;; Extract vertices (group code 10) (setq pts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) edata))) ;; Orthogonalize (setq newpts (orthogonalize-points pts)) ;; Create new polyline (setq pl (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length newpts)) '(70 . 0) ) (mapcar '(lambda (p) (cons 10 p)) newpts) (list '(62 . 1)) ) ) ) (if pl (princ "\nOrthogonal polyline created.") (princ "\nFailed to create polyline.") ) (princ) ) And here is my version - I used "green" color... (defun c:lw_orth ( / un f lw lwx pl cl ) (defun un ( l / a ll ) (while (setq a (car l)) (if (vl-some (function (lambda ( x ) (equal x a 1e-10))) l) (setq ll (cons a ll) l (vl-remove-if (function (lambda ( x ) (equal x a 1e-10))) (cdr l))) (setq ll (cons a ll) l (cdr l)) ) ) (reverse ll) ) (defun f ( l / i p1 p2 r ) (if (> (length l) 2) (progn (setq i -1) (while (< (setq i (1+ i)) (1- (length l))) (if (not p1) (setq p1 (nth i l) p2 (nth (1+ i) l)) (setq p1 p2 p2 (nth (1+ i) l)) ) (if (= i 0) (setq r (cons (car l) r)) ) (if (< (abs (- (car p2) (car p1))) (abs (- (cadr p2) (cadr p1)))) (setq r (cons (setq p2 (list (car p1) (cadr p2))) r)) (setq r (cons (setq p2 (list (car p2) (cadr p1))) r)) ) (if (= i (- (length l) 2)) (setq r (cons (last l) r)) ) ) (setq r (reverse r)) (un (apply (function append) (mapcar (function (lambda ( p1 p2 / pp ) (if (setq pp (vl-some (function (lambda ( x ) (if (and (equal (distance p1 p2) (+ (distance p1 x) (distance x p2)) 1e-10) (not (equal x p1 1e-10)) (not (equal x p2 1e-10))) x))) l)) (list p1 pp) (list p1)))) r (append (cdr r) (list (car r)))))) ) ) ) (if (and (setq lw (car (entsel "\nPick polygonal lwpolyline to make its clone orthogonalized..."))) (= (cdr (assoc 0 (setq lwx (entget lw)))) "LWPOLYLINE") (vl-every (function (lambda ( x ) (= (cdr x) 0.0))) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) lwx)) ) (progn (if (or (= (cdr (assoc 70 lwx)) 1) (= (cdr (assoc 70 lwx)) 129)) (setq cl t) ) (setq pl (mapcar (function (lambda ( p ) (trans p lw 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) lwx)))) (if cl (setq pl (append pl (list (car pl)))) ) (if (> (length pl) 2) (entmake (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length (setq pl (f pl)))) (cons 70 (if cl (1+ (* 128 (getvar (quote plinegen)))) (* 128 (getvar (quote plinegen))))) (cons 38 0.0) ) (mapcar (function (lambda ( x ) (cons 10 x))) (mapcar (function (lambda ( p ) (trans p 1 lw))) pl)) (list (cons 62 3) (list 210 0.0 0.0 1.0) ) ) ) (prompt "\nPicked lwpolyline with insufficient number of vertices...") ) ) (prompt "\nMissed, or picked entity not polygonal lwpolyline... Better luck next time...") ) (princ) ) In attached *.DWG you can see that AI version makes mistake with finalizing segment - it isn't always orthogonal... Anyway interesting and fun for coding... Regards, M.R. orthogonalize_lwpolyline.dwg

Hi All, just wanted to thank everyone again for helping me so far in my lisp journey! As a token, I worked on a VS Code extension for AutoCAD snippets. This so it can allow users to type in quickly common functions the use all the time (e.g. search layer if dont exist create layer and so on). So far I have added the comment section. Happy to receive feedback and suggestions. Thank you https://marketplace.visualstudio.com/items?itemName=CivilTechSource.autocad-lisp-snippets

Hi all, hoping someone can assist. I have an issue- when creating a 3D drawing in AutoCAD 2022, the shading on diagonal lines when in paper space appears jagged, see screen shot attached. This happens when printing to pdf/ plotting and when viewing on the screen. I am using the BASE command to import the 3D Model into a template. The shading looks fine in model space in all modes on diagonal lines. Is anyone able to please assist? Many thanks Alex

YOU ARE MY SAVIOR, BRO!!!

I did something for water pipes or electric cables in a road, it just allows you to follow line segments, with a predefined offset. I am not sure though in your last bit of Video if you want to enter the length of the last leg, can you clarify that. The code I have draws a full last length. @ScottMC not sure that overall length is required. Just a ps did you mean to post the actual code as you have the lisp file to download.

(if (minusp (- botLength 6000)) (setq botLength 6000) )

If (- botLength 6000) is minus.... (if (= (minusp (- botlength 6000)) T) ;; verifies that a number is negative (setq botLength 0) ;; if it is, it will set to 0 (setq botLength (- botLength 6000)) ;; if it isn't, it will be substracted with "6000" ) ;;End If

What are the computer specifications? What OS? Lines, LWPolylines, 2DPolylines or 3D Polylines I doubt there is a permanent fix except to repair the drawings that have the issue, though it could still be an issue with your computer graphics. If it's polylines, try exploding them to lines, then PEDIT them back to LWPolylines, also try an Audit on the affected drawings. You could post an example drawing that has the issue, maybe it will show on other's computers if it's a .dwg issue.

The OP is using AutoCAD LT 2026 and cannot use a .NET AFAIK. You are new so I removed your link to YouTube.

For me simplest and quickest is use a wipe out in the block, set to background then will auto obscure line underneath. Hopefully the result you want.

Something like this!? ; ***************************************************************************************************** ; Functions : PLBRJ ; Description : Breaking POLYLINE at blocks insertation points and joined into the one POLYLINE ; Author : Saxlle ; Date : January 19, 2026 ; ***************************************************************************************************** (prompt "\nTo run a LISP type: PLBRJ") (princ) (defun c:PLBRJ ( / ent joinList ptlist ss len spt ept i breakPoint) (setq ent (car (entsel "\nSelect the POLYLINE:")) joinList (list) ptlist (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent))) ss (ssget "_F" ptlist (list (cons 0 "INSERT"))) len (sslength ss) spt (vlax-curve-getStartPoint (vlax-ename->vla-object ent)) ept (vlax-curve-getEndPoint (vlax-ename->vla-object ent)) joinList (append (list spt) joinList) i 0 ) (while (< i len) (setq breakPoint (cdr (assoc 10 (entget (ssname ss i))))) (command "_.BREAK" breakPoint "_f" breakPoint breakPoint) (setq joinList (append (list breakPoint) joinList)) (setq i (1+ i)) ) (setq joinList (reverse (append (list ept) joinList)) ss (ssget "_F" joinList (list (cons 0 "LWPOLYLINE"))) ) (command-s "_PEDIT" "m" ss "" "j" "" "") (prompt "\nThe POLYLINE was broken at blocks insert points and joined into the one POLYLINE!") (princ) )

Try this !? You can use POINT or Insert Point of block... Break_Poly@point.lsp

Sure @karfung, but I will leave you to do that (I'm writing from the phone). This is the hint, find it everywhere in the code: (entmake (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 10 pt) (cons 11 pt) (cons 40 height) (cons 50 ang) (cons 71 5) (cons 1 (strcat def_text (rtos lenSegment 2 2) " m")))) Find this part inside: Replace this part: (cons 1 (strcat def_text (rtos lenSegment 2 2) " m")) With this: (cons 1 (strcat def_text (itoa lenSegment) " m")) and you will get the whole integer without the decimal part. I've heard the Durian, but never taste it. If I ever come to Malaysia, I will taste it . Best regards.

A slightly blunter method I use is to line everything up to a grid spacing (in my LISP I define the spacing rather than the drawing.... just in case) which usually works OK for most thing. A lot of what I do is line diagrams and the polylines are never too far out. - Get a list of points, use Lee Macs round to closest on each point, entmod the line using original and new points. I'd prefer entmod than making a new line just in case something goes wrong in between deleting the original and creating the new, retains all the original polyline info.

chat made this, (defun orthogonalize-points (pts / dx-in dx-out dy-in dy-out i in-is-h new-x new-y out-is-h p0 p1 p2 result) ;; If fewer than 3 points, nothing to do (if (< (length pts) 3) pts (progn (setq result pts) ;; Iterate interior vertices (setq i 1) (while (< i (- (length pts) 1)) (setq p0 (nth (- i 1) result)) (setq p1 (nth i result)) (setq p2 (nth (+ i 1) result)) ;; Incoming vector p0 -> p1 (setq dx-in (- (car p1) (car p0))) (setq dy-in (- (cadr p1) (cadr p0))) ;; Outgoing vector p1 -> p2 (setq dx-out (- (car p2) (car p1))) (setq dy-out (- (cadr p2) (cadr p1))) ;; Dominant direction tests (setq in-is-h (>= (abs dx-in) (abs dy-in))) (setq out-is-h (>= (abs dx-out) (abs dy-out))) ;; Case 1: Proper corner (one horizontal, one vertical) (cond ((/= in-is-h out-is-h) (if in-is-h (progn ;; incoming horizontal, outgoing vertical (setq new-x (car p2)) (setq new-y (cadr p0)) ) (progn ;; incoming vertical, outgoing horizontal (setq new-x (car p0)) (setq new-y (cadr p2)) ) ) ) ;; Case 2: both horizontal (in-is-h (setq new-x (car p1)) (setq new-y (cadr p0)) ) ;; Case 3: both vertical (t (setq new-x (car p0)) (setq new-y (cadr p1)) ) ) ;; Replace interior point (setq result (subst (list new-x new-y) p1 result)) (setq i (1+ i)) ) result ) ) ) (defun c:ORTHO_PLINE ( / edata ent newpts p pl pts x) (setq ent (car (entsel "\nSelect a polyline: "))) (if (not ent) (progn (princ "\nNothing selected.") (exit) ) ) (setq edata (entget ent)) ;; Ensure LWPOLYLINE (if (/= (cdr (assoc 0 edata)) "LWPOLYLINE") (progn (princ "\nEntity is not a lightweight polyline.") (exit) ) ) ;; Extract vertices (group code 10) (setq pts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) edata))) ;; Orthogonalize (setq newpts (orthogonalize-points pts)) ;; Create new polyline (setq pl (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length newpts)) '(70 . 0) ) (mapcar '(lambda (p) (cons 10 p)) newpts) ) ) ) (if pl (princ "\nOrthogonal polyline created.") (princ "\nFailed to create polyline.") ) (princ) )

Here are the options for edit boxes: https://help.autodesk.com/view/ACD/2026/ENU/?guid=GUID-38A11AED-DDF5-4ACA-A8BB-1F7901D0AF50 I think if you change is_enabled from true to false it should do what you want, I can't remember jus now how to switch it from one to the other - might be a google thing