Leaderboard

Indeed, if the block has attributes, (entmod) becomes more complicated: it requires going through transformation matrices and applying them to the attributes. The move command would be simpler... Here is the mhupp code adapted for proper operation: Merits to Mhupp for his code ;;----------------------------------------------------------------------------;; ;; Modify Text or Blocks to align Horozontal or Vertical ;; https://www.cadtutor.net/forum/topic/99091-i-need-a-lisp-to-align-blocks-and-texts-vertically/ (defun C:ATB () (C:AlignTextBlock)) (defun C:AlignTextBlock (/ vars vals pt1 pt2 vector mode ent ed pt newpt) (vl-load-com) (setq vars '(OSMODE ORTHOMODE) vals (mapcar 'getvar vars) ) (mapcar 'setvar vars '(0 1)) (setq pt1 (getpoint "\nAlignment Point: ")) (setq pt2 (getpoint pt1 "\nSelect Horozontal or Vertical:")) (setq vector (mapcar '- pt2 pt1)) (if (eq (car Vector) 0.0) (setq mode 'V) (setq mode 'H)) (while (setq ss (ssget '((0 . "TEXT,INSERT")))) (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))) (setq ed (entget ent) pt (cdr (assoc 10 ed)) newpt (if (eq mode 'V) (list (car pt1) (cadr pt) (caddr pt)) (list (car pt) (cadr pt1) (caddr pt))) ) (vla-Move (vlax-ename->vla-object ent) (vlax-3d-point pt) (vlax-3d-point newpt)) ; (if (or (not (assoc 11 ed)) (eq (cdr (assoc 11 ed)) '(0.0 0.0 0.0))) ;test if 11 doesnt exist or is 0,0,0 ; (setq ed (subst (cons 10 newpt) (assoc 10 ed) ed)) ; (setq ed (subst (cons 11 newpt) (assoc 11 ed) ed)) ; ) ; (entmod ed) ) ) (mapcar 'setvar vars vals) (princ) ) (princ "\nAlignTextBlock Lisp Loaded") (princ "\nType ATB or AlignTextBlock to run command")

im guessing the text is left justified and your wanting them to be aligned vertical down the center. need to update line 21 & 22 with code above. and make text center or middle justified. -edit or all the same justification. The text justification effects how the text align with the point and each other same with blocks. The insertion point is what is being updated. its the grip that shows when block is selected. --edit edit The left pic shows the grips that will be aligned to. (green dots) the right pic because they are middle justified will use the middle grip points instead of the bottom right for allignment.

You need to check if the text style has a set height because the options in the TEXT command are not the same. (defun C:ah () (hatcharea)) (defun hatcharea ( / ss area i eo pt) (setq ss (ssget '((0 . "hatch"))) area 0 i 0 ) (cond ((and(and ss) (> (sslength ss) 0)) (repeat (sslength ss) (setq eo (vlax-ename->vla-object (ssname ss i))) (setq area (+ area (vlax-get eo 'Area))) (setq i (+ i 1)) ) (while (not pt)(setq pt (getpoint "\nSelect area text insertion point >"))) (setq area (/ area 1000000.)) (if (zerop (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))) (command "_.text" pt "" "" (strcat "" (rtos area 2 2) " m²")) (command "_.text" pt "" (strcat "" (rtos area 2 2) " m²")) ) ) ) (princ) )

Was looking at the code and that cond is a bit overkill swapped it out with one line if. newpt (if (eq mode 'V) (list (car pt1) (cadr pt) (caddr pt)) (list (car pt) (cadr pt1) (caddr pt))) I also notice entmod doesn't like text that are not left justified. -edit Apparently text only uses 10 to locate if its left-justified and 11 for everything else. so need to test for that and update either 10 or 11. (if (or (not (assoc 11 ed)) (eq (cdr (assoc 11 ed)) '(0.0 0.0 0.0))) ;test if 11 doesnt exist or is 0,0,0 (setq ed (subst (cons 10 newpt) (assoc 10 ed) ed)) (setq ed (subst (cons 11 newpt) (assoc 11 ed) ed)) ) (entmod ed)

Using @BIGAL suggestion for ssget to only pick up text and blocks set in a while loop so you can align multiple things to the same axis. also added a visual to choose between horizontal or vertical alignment. AlignT&B.lsp

Very quickly try these changes: (setq alpty (cadr alpt)) ---> (setq alptx (car alpt)) (setq newpt (list inptx alpty)) --> (setq newpt (list alptx inpty))

Hello, for a project I needed to find the shortest way between two points in a network, so I searched for a pathfinding algorithm in AutoLISP. Since I did not find anything - here comes my implementation of the A* pathfinding algorithm. (If you don't know what A* is - I got my information here: http://en.wikipedia.org/wiki/A*_search_algorithm) The program finds the shortest way in a network of polylines between two points, the polylines representing the paths you are allowed to move along. Two polylines are considered connected if one of their vertices match. The resulting path is returned as a new polyline. The program and a test.dwg are attached to this post. I would like to extent the network/edges in a way, that polylines are also considered connected if the vertice of one of them is on the line of another. I could use some help with that. I hope this is useful for someone. astar_01.lsp test_01.dwg

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

I think I chose the wrong version from my test code in the previous release. There are some bugs that affect drawings containing splines. This version should fix those bugs. ;; 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 -Added a new function 'EBiPts' to control obtaining coordinates from LINE and SPLINE objects -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 to sp pl) (setq i -1 id (cdr (assoc 5 (setq l (entget en)))) c (= (setq to (cdr (assoc 0 l))) "LINE") sp (= to "SPLINE") pl (= to "POLYLINE")); a 10) (while (setq p (if (and (setq i (1+ i)) (or c sp pl)) (eBiPts en i) (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 lstClvs (subst (append val (list (cons id i))) val lstClvs)) (setq lstClvs (cons (list clv (cons id i)) lstClvs)) ) ) ) (defun ·dist· (r e p1 p2) (if r (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 to sp pl) (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 (= (setq to (cdr (assoc 0 (setq l (entget e))))) "LINE") sp (= to "SPLINE") pl (= to "POLYLINE")) (if (zerop (setq pr (cdr par))) (setq lr (cons (list (cond (c "l") (sp "s") (pl "p")) e pr (1+ pr)) lr)) (setq lr (cons (list (cond (c "l") (sp "s") (pl "p")) e (1- pr) pr) lr) lr (if ((if (or c sp pl) eBiPts vlax-curve-getPointAtParam) e (1+ pr)) (cons (list (cond (c "l") (sp "s") (pl "p")) e pr (1+ pr)) lr) lr) ) ) ) ) ) (defun eBiPts (e pr / v0 v1 lp) (cond ((zerop pr) (vlax-curve-getStartPoint e)) ((= pr 1) (vlax-curve-getEndPoint e))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ; ;; 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 f e r temp) (setq pt (car node) fcost (caddr node) ) (setq lEdges (getCell pt)) (foreach edge lEdges (setq f (if (setq r (member (car edge) '("l" "s" "p"))) eBiPts vlax-curve-getPointAtParam);new e (cadr edge);new pr1 (caddr edge);new pr2 (cadddr edge);new p1 (f e pr1);new p2 (f e pr2);new d (·dist· r 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) ) PS: As I mentioned earlier, the object representing the route remains the same polyline as in the previous code examples. Therefore, although the calculations did take curved segments into account, the final polyline marking the route will still draw straight segments.

There is also THIS.