All Activity

Hi... I've seen @GLAVCVS code and found that it has some lacks... I've debugged it and make it work for lines and path in 3d... Path is now 3D POLYLINE and selection of network edges are lines in 3D... I've shortened complete code and left only necessary subs and comments... So, this is my revision and I hope it could also be beneficial... ;; 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))....(xn yn zn))) ; ;; ; ;; 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* (/ addToDict getCell upd_openlst in_openlst get_path memberfuzz mk_3dpl set_errhandler *error* ssl i startp endp 3dpl openlst closelst found acdoc lstClvs Pathlay Pathcol Pathlwt node ti ) (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS ;;;Create dictionary (defun addToDict (en / i id p val clv) (setq i -1 id (cdr (assoc 5 (entget en)))) (while (and (/= (setq i (1+ i)) 2) (if (= i 0) (setq p (vlax-curve-getStartPoint en)) (setq p (vlax-curve-getEndPoint en)))) (if (setq val (assoc (setq clv (strcat (rtos (car p) 2 4) "-" (rtos (cadr p) 2 4) "-" (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 par e lr) (if (setq val (assoc (setq clv (strcat (rtos (car pt) 2 4) "-" (rtos (cadr pt) 2 4) "-" (rtos (caddr pt) 2 4))) lstClvs)) (foreach par (cdr val) (setq e (handent (car par))) (setq lr (cons (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint 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 (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 ) ;; ; ;; mk_3dpl ; ;; ; ;; Draw an 3dpolyline given a point list ; ;; ; ;; Will be drawn on layer, lineweight and color defined by Variables ; ;; at beginnung of program. ; ;; ; (defun mk_3dpl (pl / 3dpl) (setq 3dpl (entmakex (list (cons 0 "POLYLINE") (cons 100 "AcDbEntity") (cons 8 Pathlay) (cons 370 Pathlwt) (cons 100 "AcDb3dPolyline") (cons 66 1) (list 10 0.0 0.0 0.0) (cons 70 8) (cons 40 0.0) (cons 41 0.0) (list 210 0.0 0.0 1.0) (cons 71 0) (cons 72 0) (cons 73 0) (cons 74 0) (cons 75 0) (cons 62 Pathcol) ) ) ) (foreach p pl (entmake (list (cons 0 "VERTEX") (cons 100 "AcDbEntity") (cons 8 Pathlay) (cons 100 "AcDbVertex") (cons 100 "AcDb3dPolylineVertex") (cons 10 p) (cons 40 0.0) (cons 41 0.0) (cons 42 0.0) (cons 70 32) (cons 50 0.0) (cons 71 0) (cons 72 0) (cons 73 0) (cons 74 0) ) ) ) (entmake (list (cons 0 "SEQEND") (cons 100 "AcDbEntity") (cons 8 Pathlay) (cons -2 3dpl) ) ) 3dpl ) ;; Error Handler by Elpanov Evgenyi ; (defun set_errhandler (l) (setq varl (mapcar (function (lambda (a) (list (quote setvar) a (getvar a)))) l)) ) (defun *error* (msg) (if 3dpl (if command-s (command-s "_.draworder" 3dpl "" "_f") (vl-cmdf "_.draworder" 3dpl "" "_f") ) ) (mapcar (function eval) varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (vla-endundomark acdoc) (princ) ) ; 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 entities...") (if (setq ssl (ssget (list (cons 0 "LINE")))) (foreach en (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ssl))) (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 (setq 3dpl (mk_3dpl (get_path closelst))) (alert "No path was finded...") ) (princ (strcat "\nExecution time : " (itoa (- (getvar (quote millisecs)) ti)) " milliseconds...")) (*error* nil) ) HTH. Regards, M.R.

hello, I am looking for help on plate 2 so if you happen to have already completed it, or have any visuals, it would be greatly appreciated

Another been using for years, pads dwg number. We named our layouts as D01, D02 etc. ; if less than 10 (if (< dwgnum 10.0) (setq newstr2 (strcat dwgname "-D0" (rtos dwgnum 2 0))) (setq newstr2 (strcat dwgname "-D" (rtos dwgnum 2 0))) ) ; can add more "0" to get "001" etc. use a cond. (cond ((< dwgnum 10) (setq newstr2 (strcat dwgname "-D00" (rtos dwgnum 2 0)))) ((< dwgnum 100) (setq newstr2 (strcat dwgname "-D0" (rtos dwgnum 2 0)))) ((>= dwgnum 100)(setq newstr2 (strcat dwgname "-D" (rtos dwgnum 2 0)))) ) Maybe a bit shorter than the Vl string trim.

Thanks @Nikon for the improvements to the code. Have saved the new version.

No, id don't use any of those. Many thanks.

Verticals are Civil 3D, AutoCAD Map 3D, AutoCAD Mechanical, AutoCAD Architectural, etc. I'm busy at work start to finish these days, if I get time I'll see if I can discover the issue.

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)

Hi SLW210. No. I only use AutoCAD 2014. What is Verticals? It seems that there are too many tag-alongs in your drawings, even when they are visibly empty. Export to DXF? Thank you.

Are any of your drawings coming from or being worked on in AutoCAD Verticals or other CAD programs? It seems as though there are a lot of excessive tag-alongs in your drawings even when visibly empty. You might also try a DXFOUT and DXFIN to a new drawing.

Thank you. It's a very useful application. I'm also trying to improve something like this with artificial intelligence. @Nikon

Wait, does the same thing happen in 2021 and 2021F? If the system has updated, maybe the plotters have too. Or you just need to configure them. If you're in a hurry, is there some other app that can import a file type that AutoCAD exports? Doesn't have to be DWG. Then the other app can print to PDF. Problem (temporarily) solved.

What is CyberAngle? Thanks, Su Leone, PLS Raleigh NC

I tried something. Just import a word from the old design into these new ones and the weight immediately rises to the value of the originals! Thanks again.

Hi Bandido, I have no idea if it is different as I don't have Autocad. But I'm glad it seemed to have worked for you.

Good morning. Everything looks fine to me. Is wblock in Briscad the same as Autocad? Thank you very much.

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

Good morning. I used the clean logo placed here by SLW210, but I still have a problem with the weight of the drawings. I've already tried wblock, purge, -purge, and overkill, but nothing works! What could be causing the weight in the drawings? Here is a link to five drawings that have the same problem. Thank you very much for your help. https://we.tl/t-3IquP6IBQ5 Thanks again.

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

Since you're on a Mac, you might want to double-check if you have the 'AutoCAD PDF' drivers available in your Plotter configuration. Sometimes after a macOS update, the system printers act up, but the built-in AutoCAD ones (like 'AutoCAD PDF (General Documentation).pc3') are more stable than using the 'Save to PDF' button at the bottom of the system dialog.

Thank you, but it didn't work in this form. @BÜYÜK

Looks OK to me, and a nice acceleration. ymg

I thought it was a given that all intersections necessarily divide the polylines. I must admit I didn't see your drawing until now. I apologize for that. I've attached modified code to fix this. ;; 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 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* (/ 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)); 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 (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 ;;*** Modified to consider all segments within any polyline *** (defun addToDict (en / p1 p2 id clv i) (setq i -1 id (cdr (assoc 5 (entget en)))) (while (setq p (vlax-curve-getPointAtParam en (setq i (1+ 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 ;;*** Modified to access the new dictionary format *** (defun getCell (pt / clv v lr id p pr par) (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))) (if (zerop (setq pr (cdr par))) (setq lr (cons (list (butlast (vlax-curve-getPointAtParam e pr)) (butlast (vlax-curve-getPointAtParam e (1+ pr)))) lr)) (setq lr (cons (list (butlast (vlax-curve-getPointAtParam e (1- pr))) (butlast (vlax-curve-getPointAtParam e pr))) lr) lr (if (setq p (vlax-curve-getPointAtParam e (1+ pr))) (cons (list (butlast (vlax-curve-getPointAtParam e pr)) (butlast 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 ((equal pt p1 1e-4) (setq temp (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp)))) ; p p0 distAcum (distAcum + distRestante) ) ((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))); si el punto en avance candidato no está ya en '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)))) ;ordena los coincidentes por orden de progresión hacia destino ) ) ;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); si el primer elemento de 'node' (punto) es igual que el primero del primer elemento de 'lst' (if (< (cadddr node) (cadddr (car lst))); si (distancia acumulada + restante) es menor en 'node' que en '(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) )

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

This is very useful. Is there a version of this where I can only select some blocks and not all of them?

Ok its simple to use vpoint to set your view angles, code is part of a view choice lisp. (if (= look "R")(command-s "-vpoint" "1,0,0")) (if (= look "L")(command-s "-vpoint" "-1,0,0")) (if (= look "F")(command-s "-vpoint" "0,-1,0")) (if (= look "B")(command-s "-vpoint" "0,1,0")) (if (= look "P")(command-s "-vpoint" "0,0,1")) (if (= look "3")(command "_.vpoint" "-1,-1,1")) If you want auto 3 viewports then you need to ask what scale and pick say a point in model so the views can be based around that point. I would use a layout with a title block.