Leaderboard

After seeing @BIGAL's suggestion, I'm wondering if I understood correctly what you're asking, Vica. Anyway, I'm attaching a short clip of what I'm talking about. FACTVM de ARCTIS.mp4 I’ve implemented a small emulator of the "pline" command in the base code, but each user should implement the code they need for their specific task instead. Basically, the distance variation from the last stored point in LASTPOINT is displayed above the cursor (though this can be easily changed by modifying the textoGR1 function). Below the cursor, any desired information about the object under it will be shown (or not, if visibility is toggled by pressing the F10 key). This information must be passed to the textoGR2 function as a list of (Property_Name StringValue) pairs. The main code must be implemented in the 'FuncionPrincipal' function.

I copied another function of dijkstra's algorithm to find the shortest path. It might need a lot of optimization, but just as a proof of concept. centerline voronoi dijkstra.lsp Code I forgot to include: (defun RemoveDuplicatesAux ( x ) (cond ((vl-position x index)) ((null (setq index (cons x index)))) ) ) (defun RemoveDuplicates ( lst / index ) (vl-remove-if 'RemoveDuplicatesAux lst ) )

[code edited 11/3/2025] I have enjoyed the discussion of this thread. As I gave the task more thought and anaysis it became more clear that the task was not simple. As it appears that there is still no satisfacory solution I thought I would offer the following. The first goal for me was to create a function that would create a midline between two non parallel lines. The mid-lines extents should be a function of the given line segments. This function could then be used in a program that would step through the line segments of one of the polylines and search the other polyline for relevant segments. The function "midline" accepts four points. The first two points, A1 and A2, are the ends of one line sement while the thrid and fourth points, B1 and B2, are the ends of an opposing ilne segments. The diagram below details the variables in the function. The program uses vectors as I prefer them over angles which present, for me, a variety of problems. uA = unit vector in the diection from A1 to A2 uB = unit vector in the direction from B1 to B2 uBisector = unit vector in the direction of the angle bisector of uA and UB The ends of the two lines are projected onto the bisecting line defining 4 points, A1M, A2M, B1M, B2M. I debated which of the points to output for the line to be drawn. I first used the closest and furthest points from the intersecttion point ABIntr but I found it more helpful to use the two intermediate points (A1M and A2M in the example above). Here's an example of the results after manually steppng alone the polyline. Looking at the area circled in red we find: To fill the gap we need a curve that starts with a radius of 0.1514 and ends with a radius of 0.1693. This can be done with a spline or you may find it acceptable to extend the two lines to the point of intersection. The best way to create the spline is to use the Control Vertex Method and use the two endpoints and the imaginary point of intersecton for the middle CV. This ensures tangency to the two lines. As can be seen below the distance to a random point along the spline (red) agree! Run the program "test" and specify the end points of a line segment on one of the polylines, then the endpoints on a line segment on the opposing polyline. I have found the results very accurate and although it may not be used for creating the complete "hybrid " polyline it is helpful in finding the correct line for a specific segment. ;;---------------------------------------------------------------------------- ;; Determines the endpoints of a line the is midway between two lines defined by their end points. ; Input: 4 points, the ends of the first line followed by the ens of the second line ; Output: a list containing the two point of the midline if there's a solution and nil if no solution ; L. Minardi 10/31/2025 - Revised 11/3/2025 (defun midLine (a1 a2 b1 b2 / ua ub p vp d s a1m a2m b1m b2m d1 d2 d3 d4 slist a1p a2p b1p b2p m1 m2 mmid mp) (setq ua (unitVecAB a1 a2) ub (unitVecAB b1 b2) ) (if (< (dot ua ub) 0.0) (setq ub (mapcar '* ub '(-1 -1 -1))) ) (if (> (abs (dot ua ub)) 0.9999) ; are lines parallel? (progn ; lines are parallel (setq p (mapcar '/ (mapcar '+ a1 b1) '(2 2 2)) ; point on midline vp (list (- (cadr ua)) (car ua) 0.0) ; vector perpendicular to ua d (/ (dot (mapcar '- b1 a1) vp) 2.0) ; distance to midline s (dot (mapcar '- a1 p) ua) a1m (mapcar '+ p (mapcar '* ua (list s s s))) s (dot (mapcar '- a2 p) ua) a2m (mapcar '+ p (mapcar '* ua (list s s s))) s (dot (mapcar '- b1 p) ua) b1m (mapcar '+ p (mapcar '* ua (list s s s))) s (dot (mapcar '- b2 p) ua) b2m (mapcar '+ p (mapcar '* ua (list s s s))) d1 0.0 d2 (dot ua (mapcar '- a2m a1m)) d3 (dot ua (mapcar '- b1m a1m)) d4 (dot ua (mapcar '- b2m a1m)) ) (setq slist ; sorted list of distances (vl-sort (list (list a1m d1) (list a2m d2) (list b1m d3) (list b2m d4)) (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))))) ; use the middle two mid point from the line (setq m1 (car (nth 1 slist)) m2 (car (nth 2 slist)) ) (setq mmid (mapcar '/ (mapcar '+ m1 m2) '(2 2 2))) (setq mp (* (dot (mapcar '- a1m mmid) (mapcar '- a2m mmid)))) (if (<= mp 0) (setq theLine (list m1 m2)) (setq theline nil) ) ;;;;; ) ) ; end lines parallel (progn ; lines are not parallel (setq ABIntr (inters A1 A2 B1 B2 nil)) (setq p (mapcar '+ ABIntr (mapcar '/ (mapcar '+ ua ub) '(2 2 2))) ;(setq p (mapcar '+ ABIntr (mapcar '/ (mapcar '+ a1 b1) '(2 2 2))) uBisector (unitVecAB ABIntr p) vp (list (- (cadr ua)) (car ua) 0.0) A1p (mapcar '+ A1 vp) a1m (inters A1 A1P ABIntr p nil) A2p (mapcar '+ A2 vp) a2m (inters A2 A2P ABIntr p nil) vp (list (- (cadr ub)) (car ub) 0.0) B1p (mapcar '+ B1 vp) B1m (inters B1 B1P ABIntr p nil) B2p (mapcar '+ B2 vp) B2m (inters B2 B2P ABIntr p nil) d1 (distance ABIntr a1m) d2 (distance ABIntr a2m) d3 (distance ABIntr b1m) d4 (distance ABIntr b2m) ) (setq slist (vl-sort (list (list a1m d1) (list a2m d2) (list b1m d3) (list b2m d4)) (function (lambda (e1 e2) (< (cadr e1) (cadr e2))))) ) (setq m1 (car (nth 1 slist)) m2 (car (nth 2 slist)) ) (setq mmid (mapcar '/ (mapcar '+ m1 m2) '(2 2 2))) (setq mp (* (dot (mapcar '- a1m mmid) (mapcar '- a2m mmid)))) (if (<= mp 0) (setq theLine (list m1 m2)) (setq theline nil) ) ) ; end lines not parallel ) ; end if ) ; test function (defun c:test ( / a1 a2 b1 b2 mline ) (setq a1 (getpoint "\nEnter start point of first line: ") a2 (getpoint a1 "\nEnter end point of first line: ") b1 (getpoint "\nEnter start point of second line: ") b2 (getpoint b1 "\nEnter end point of second line: ") mline (midline a1 a2 b1 b2) ) (if mline (command "_line" "_non" (car mline) "_non" (cadr mline) "") (princ "\nNo Solution!") ) (princ) ) ; unit vector from point A to point B (defun unitVecAB (A B / x) (setq x (distance A B) x (mapcar '/ (mapcar '- B A) (list x x x)) ) ) ; dot product of vectors A and B (defun dot (A B / x) (setq x (mapcar '* A B)) (setq x (+ (nth 0 x) (nth 1 x) (nth 2 x))) );end of dot mid -poly.06.lsp

I wrote this program like four years ago (just for fun / exercise) and maybe used it once or twice so as we say here on Mars : guaranteed to the doorstep If it works : , if it doesn't ... As usual never wrote a manual so have fun experimenting. RlxBlockSync.lsp

I added extra checks on every vertex like @PGia suggested two weeks ago. Those I added to the offset-loop and it gives the best of both worlds. Every point that is calculated should be the exact middle because the offset is the same on both sides. Still not perfect, but pretty close I think. ;| ; Calculate centerline between two polylines - dexus ; Function checks intersections of the offsets of two lines to create a middle/avarage line. |; (defun c:cl (/ ent1 ent2 loop maxlen offset offsetdistance pts s1 s2 ss start LM:ProjectPointToLine LM:intersections _addPoints _avarageAngle _cornerOffset _doOffset _getAnglesAtParam _getLength _polyline _side _wait) ;| ; Draw Polyline - dexus ; Draw a polyline from a list of points, but filter out colinear points ; @Param lst list of points ; @Returns ename of polyline |; (defun _polyline (lst / prev pts) (while lst (cond ((and (cdr lst) prev (null (inters prev (car lst) prev (cadr lst))))) ((setq pts (cons (cons 10 (setq prev (car lst))) pts))) ) (setq lst (cdr lst)) ) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length pts)) (cons 8 (getvar 'clayer)) (cons 70 0) ) (reverse pts) ) ) ) (defun _side (pline pnt / cpt end target der) (setq cpt (vlax-curve-getClosestPointTo pline pnt) ; https://www.theswamp.org/index.php?topic=55685.msg610429#msg610429 end (vlax-curve-getEndParam pline) target (vlax-curve-getParamAtPoint pline cpt) der (if (and (equal target (fix target) 1e-8) (or (vlax-curve-isClosed pline) (and (not (equal (vlax-curve-getStartParam pline) target 1e-8)) (not (equal end target 1e-8))) ) ) (mapcar '- (polar cpt (angle '(0 0) (vlax-curve-getFirstDeriv pline (rem (+ target 1e-3) end))) 1.0) (polar cpt (angle (vlax-curve-getFirstDeriv pline (rem (+ (- target 1e-3) end) end)) '(0 0)) 1.0) ) (vlax-curve-getFirstDeriv pline target) ) ) (minusp (sin (- (angle cpt pnt) (angle '(0.0 0.0) der)))) ) ;; Intersections - Lee Mac ;; mod - [int] acextendoption enum of intersectwith method (defun LM:intersections ( ob1 ob2 mod / lst rtn ) (if (and (vlax-method-applicable-p ob1 'intersectwith) (vlax-method-applicable-p ob2 'intersectwith) (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)) ) (repeat (/ (length lst) 3) (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn) lst (cdddr lst)) ) ) (reverse rtn) ) (defun _getLength (ent) (- (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (vlax-curve-getDistAtParam ent (vlax-curve-getStartParam ent)) ) ) (defun _wait (msec) (not ( (lambda (start) (while (< (- (getvar 'millisecs) start) msec)) ) (getvar 'millisecs) ) ) ) (defun _addPoints (lst ent pts / len) (setq len (_getLength ent)) (setq lst (mapcar (function (lambda (pt) (list (/ (vlax-curve-getDistAtPoint ent pt) len) pt))) lst)) (setq pts (append lst pts)) ; Animation ; (setq pts (vl-sort pts (function (lambda (a b) (< (car a) (car b)))))) ; (redraw) ; ( ; (lambda (lst) ; (while (cadr lst) ; (grdraw (cadar lst) (cadadr lst) 3) ; (setq lst (cdr lst)) ; ) ; ) ; pts ; ) ; (vla-update ent) ; (_wait 40) ; End animation pts ) (defun _doOffset (offset / te1 te2 lst rtn) ; Global vars: pts ent1 ent2 s1 s2 (setq rtn (cond ((equal offset 0.0 1e-4) (if (setq lst (LM:intersections ent1 ent2 acExtendNone)) (setq pts (_addPoints lst ent1 pts)) ) lst ) ( (or ; Make offset (vl-catch-all-error-p (setq te1 (vl-catch-all-apply 'vlax-invoke (list ent1 'Offset (if s1 offset (- offset)))))) (vl-catch-all-error-p (setq te2 (vl-catch-all-apply 'vlax-invoke (list ent2 'Offset (if s2 offset (- offset)))))) (vla-put-color (car te1) 252) (vla-put-color (car te2) 252) ) (princ "\nOffset failed. ") nil ) ((setq lst (LM:intersections (car te1) (car te2) acExtendNone)) (setq pts (_addPoints lst (car te1) pts)) lst ) ) ) (if (and te1 (not (vl-catch-all-error-p te1))) (mapcar 'vla-delete te1)) (if (and te2 (not (vl-catch-all-error-p te2))) (mapcar 'vla-delete te2)) rtn ) ;| ; Project Point onto Line - Lee Mac ; @Param pt point to project ; @Param p1 first point of line ; @Param p2 second point of line ; @Returns projected point |; (defun LM:ProjectPointToLine ( pt p1 p2 / nm ) (setq nm (mapcar '- p2 p1) p1 (trans p1 0 nm) pt (trans pt 0 nm)) (trans (list (car p1) (cadr p1) (caddr pt)) nm 0) ) (defun _getAnglesAtParam (ent pa / ang1 ang2) (if (and (vlax-curve-isClosed ent) (= pa 0)) ; Special case for closed Polyline (list (setq ang1 (vlax-curve-getFirstDeriv ent 1e-14)) (setq ang2 (vlax-curve-getFirstDeriv ent (- (fix (vlax-curve-getEndParam ent)) 1e-14))) ) (list (setq ang1 (vlax-curve-getFirstDeriv ent (+ pa 1e-14))) (setq ang2 (vlax-curve-getFirstDeriv ent (- pa 1e-14))) ) ) (setq ang1 (angle '(0 0 0) ang1)) (setq ang2 (angle '(0 0 0) ang2)) (list ang1 (* (+ ang1 ang2) 0.5) ang2) ) ;| ; Avarage Angle - dexus ; Get angle of a line between two angles ; @Param ang1 real - Angle in radians ; @Param ang2 real - Angle in radians ; @Returns real - Angle in radians |; (defun _avarageAngle (ang1 ang2) (if (< (rem (+ ang1 pi) (+ pi pi)) (rem (+ ang2 pi) (+ pi pi)) ) (+ (* (- ang2 ang1) 0.5) ang1) (+ (* (- ang1 ang2) 0.5) ang2) ) ) ;| ; Calculate exact offset distance on a corner - dexus ; pt1 - Point on corner ; pt2 - Point on other side ; pt3 - Center for bisector ; pt4 - Target for corner of the offset ; pt5 - Find perpendicular point for offset distance ; / ; / ; -------- pt1 pt5 ; \ / ; pt4 ; \ ; ---- pt3 ----- pt2 ----- ; ; @Param ent1 Line to check corners ; @Param ent2 Opposing line ; @Returns List of offset distances (pt1 -> pt5) to calculate |; (defun _cornerOffset (ent1 ent2 / ang1 ang2 ang3 index pt1 pt2 pt3 pt4 pt5 rtn tmp vertex) (setq vertex (fix (vlax-curve-getEndParam ent1)) halfPi (* pi 0.5) index 0) (repeat vertex (and (setq pt1 (vlax-curve-getPointAtParam ent1 index)) ; Point on corner (setq ang1 (_getAnglesAtParam ent1 index)) ; Angles of pt1 (setq tmp ; Temp line for finding the angle on the other side (entmakex (list '(0 . "line") (cons 10 (polar pt1 (+ (cadr ang1) halfPi) maxlen)) (cons 11 (polar pt1 (- (cadr ang1) halfPi) maxlen)) ) ) ) (setq pt2 (car (LM:intersections (vlax-ename->vla-object tmp) ent2 acExtendNone))) ; Point on other side (setq ang2 (_getAnglesAtParam ent2 (vlax-curve-getParamAtPoint ent2 pt2))) ; Angle of pt2 (if (equal (rem (car ang1) pi) (rem (car ang2) pi) 1e-9) ; Is parallel? (and (setq pt3 (mapcar (function (lambda (a b) (* (+ a b) 0.5))) pt1 pt2)) ; Midpoint (setq ang3 (car ang1)) ; Same angle als ang1 ) (and (setq pt3 (inters pt1 (polar pt1 (car ang1) 1) pt2 (polar pt2 (car ang2) 1) nil)) ; Find center for bisector (setq ang3 (_avarageAngle (angle pt1 pt3) (angle pt2 pt3))) ; Angle of bisector ) ) (setq pt4 (inters pt3 (polar pt3 ang3 1) pt1 (polar pt1 (+ (cadr ang1) halfPi) 1) nil)) ; Find target for corner of the offset (setq pt5 (LM:ProjectPointToLine pt4 pt1 (polar pt1 (+ (car ang1) halfPi) maxlen))) ; Find perpendicular point for offset distance (setq rtn (cons (distance pt1 pt5) rtn)) ; Return offset distance ) (if (entget tmp) (entdel tmp)) (setq index (1+ index)) ) rtn ) (if (not (while (cond ((not (setq ss (ssget '((0 . "LWPOLYLINE"))))) (princ "\nNothing selected. Try again...\n") ) ((/= (sslength ss) 2) (princ "\nSelect 2 polylines! Try again...\n") ) ((and (setq ent1 (ssname ss 0)) (setq ent2 (ssname ss 1)) (setq ent1 (vlax-ename->vla-object ent1)) (setq ent2 (vlax-ename->vla-object ent2)) ) nil ; Stop loop ) ) ) ) (progn (setq s1 (_side ent1 (vlax-curve-getStartPoint ent2))) (setq s2 (_side ent2 (vlax-curve-getStartPoint ent1))) (setq maxlen (* 1.1 (max (_getLength ent1) (_getLength ent2) (distance (vlax-curve-getStartPoint ent1) (vlax-curve-getStartPoint ent2))))) (setq offsetdistance (/ maxlen 1024.0)) (if (LM:intersections ent1 ent2 acExtendNone) (setq offset (- maxlen)) (setq offset 0.0) ) (mapcar '_doOffset (_cornerOffset ent1 ent2)) (mapcar '_doOffset (_cornerOffset ent2 ent1)) (while (progn (setq loop (cond ((> offset maxlen) nil) ((_doOffset offset) (setq start t)) ((not start) t) (start nil) ) ) (setq offset (+ offset offsetdistance)) loop ) ) (if pts (_polyline (mapcar 'cadr (vl-sort pts (function (lambda (a b) (< (car a) (car b))))))) ) ) ) (redraw) (princ) )

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

From what I inspected... That @dexus code works well with correct implementation of djikstra... When I used his code it bumped into endless (while) loop... Here is my revision and it should work, but result is not exact... Seems that resulting polyline is rummaging between references... Here is my revision : ; Attempt at drawing a centerline using voronoi diagram ; Voronoi diagram calculations found here: https://www.theswamp.org/index.php?topic=45085.msg503034#msg503034 (defun c:cl (/ _side ent->pts removeDuplicates minlen RemoveIDDup minpath1 triangulate getcircumcircle ss ent1 ent2 pl s1 s2 vor line) (defun _side (pline pnt / cpt end target der) (setq cpt (vlax-curve-getClosestPointTo pline pnt) ; https://www.theswamp.org/index.php?topic=55685.msg610429#msg610429 end (vlax-curve-getEndParam pline) target (vlax-curve-getParamAtPoint pline cpt) der (if (and (equal target (fix target) 1e-8) (or (vlax-curve-isClosed pline) (and (not (equal (vlax-curve-getStartParam pline) target 1e-8)) (not (equal end target 1e-8))) ) ) (mapcar (function -) (polar cpt (angle (list 0.0 0.0) (vlax-curve-getFirstDeriv pline (rem (+ target 1e-3) end))) 1.0) (polar cpt (angle (vlax-curve-getFirstDeriv pline (rem (+ (- target 1e-3) end) end)) (list 0.0 0.0)) 1.0) ) (vlax-curve-getFirstDeriv pline target) ) ) (minusp (sin (- (angle cpt pnt) (angle (list 0.0 0.0) der)))) ) (defun _polyline (pts) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length pts)) (cons 8 (getvar (quote clayer))) (cons 70 0) ) (mapcar (function (lambda (x) (cons 10 x))) pts) ) ) ) (defun ent->pts (ent acc / end ind step rtn) (setq end (vlax-curve-getEndParam ent)) (setq ind (vlax-curve-getStartParam ent)) (setq step (/ end (float acc))) (while (< ind end) (setq rtn (cons (vlax-curve-getPointAtParam ent ind) rtn)) (setq ind (+ ind step)) ) rtn ) (defun removeDuplicates (lst / a ll) (while (setq a (car lst)) (if (vl-some (function (lambda (x) (equal x a 1e-6))) (cdr lst)) (setq ll (cons a ll) lst (vl-remove-if (function (lambda (x) (equal x a 1e-6))) (cdr lst))) (setq ll (cons a ll) lst (cdr lst)) ) ) (reverse ll) ) ; https://www.theswamp.org/index.php?topic=45092.msg578984#msg578984 (defun minlen (LtsLine startEnd / ID1 ID2 IDEnd IDStart LtsID LtsIDFil LtsIDPnt LtsID_Edge LtsPath P1 P2 listpoint) (setq LtsPnt (removeDuplicates (apply (function append) LtsLine))) (setq LtsIDPnt (mapcar (function (lambda (x) (list (vl-position x LtsPnt) x))) LtsPnt)) (setq LtsID (mapcar (function (lambda (x) (vl-position x LtsPnt))) LtsPnt)) (setq IDStart (vl-position (caar startEnd) LtsPnt)) (setq IDEnd (vl-position (caadr startEnd) LtsPnt)) (setq LtsID_Edge (list)) (foreach e LtsLine (setq ID1 (caar (vl-remove-if-not (function (lambda (x) (equal (car e) (cadr x) 1e-6))) LtsIDPnt))) (setq ID2 (caar (vl-remove-if-not (function (lambda (x) (equal (cadr e) (cadr x) 1e-6))) LtsIDPnt))) (setq LtsID_Edge (append LtsID_Edge (list (list ID1 ID2 (distance (nth ID1 LtsPnt) (nth ID2 LtsPnt)))))) ) (setq LtsIDFil (RemoveIDDup LtsID_Edge)) (setq LtsPath (minpath1 IDStart IDEnd LtsID LtsIDFil)) (setq listpoint (mapcar (function (lambda (x) (nth (car x) LtsPnt))) LtsPath)) ) (defun RemoveIDDup (l) (if l (cons (car l) (RemoveIDDup (vl-remove-if (function (lambda (x) (or (and (= (car x) (car (car l))) (= (cadr x) (cadr (car l))) ) (and (= (car x) (cadr (car l))) (= (cadr x) (car (car l))) ) ) )) (cdr l) ) ) ) ) ) (defun minpath1 (g f nodes edges / brname clnodes closedl go new nodname old openl totdist ppath) (setq nodes (vl-remove g nodes)) (setq openl (list (list g 0 nil))) (setq closedl nil) (setq go t) (foreach n nodes (setq nodes (subst (list n 0 nil) n nodes)) ) (while (and go (not (= (caar closedl) f))) (setq nodname (caar openl)) (setq totdist (cadar openl)) (setq closedl (cons (car openl) closedl)) (setq openl (cdr openl)) (setq clnodes (mapcar (function car) closedl)) (foreach e edges (setq brname nil) (cond ( (= (car e) nodname) (setq brname (cadr e)) ) ( (= (cadr e) nodname) (setq brname (car e)) ) ) (if brname (progn (setq new (list brname (+ (caddr e) totdist) nodname)) (cond ( (member brname clnodes) ) ( (setq old (vl-some (function (lambda (x) (if (= brname (car x)) x))) openl)) (if (< (cadr new) (cadr old)) (setq openl (subst new old openl)) ) ) ( t (setq openl (cons new openl)) ) ) ) ) ) (setq openl (vl-sort openl (function (lambda (a b) (< (cadr a) (cadr b)))))) (and (null openl) (null (caar closedl)) (setq go nil)) ) (setq ppath (list (car closedl))) (foreach n closedl (if (= (car n) (caddr (car ppath))) (setq ppath (cons n ppath)) ) ) ppath ) ;;***************************************************************************; ;; Triangulate ; ;; Structure of Program by ElpanovEvgeniy ; ;; 17.10.2008 ; ;; edit 20.05.2011 ; ;; Program triangulate an irregular set of 3d points. ; ;; Modified and Commented by ymg June 2011. ; ;; Modified to operate on index by ymg in June 2013. ; ;; Contour Generation added by ymg in July 2013. ; ;; Removed lots of code not used for centerline function November 2025. ; ;;***************************************************************************; (defun triangulate (pl / a al b bb c cp ctr e el epos l n np npos pt r sl tl tr vl vor xmax xmin ymax ymin) (if pl (progn (setq tl nil pl (vl-sort pl (function (lambda (a b) (< (car a) (car b))))) ; Sort points list on x coordinates bb (list (apply 'mapcar (cons 'min pl)) (apply 'mapcar (cons 'max pl))) ; Replaced code to get the min and max with 3d Bounding Box Routine ; A bit slower but clearer. zmin and zmax kept for contouring xmin (caar bb) xmax (caadr bb) ymin (cadar bb) ymax (cadadr bb) np (length pl) ; Number of points to insert cp (list (/ (+ xmin xmax) 2.0) (/ (+ ymin ymax) 2.0)) ; Midpoint of points cloud and center point of circumcircle through supertriangle. r (* (distance cp (list xmin ymin)) 20) ; This could still be too small in certain case. No harm if we make it bigger. sl (list (list (+ (car cp) r) (cadr cp) 0) (list (- (car cp) r) (+ (cadr cp) r) 0) (list (- (car cp) r) (- (cadr cp) r) 0) ) ; sl list of 3 points defining the Supertriangle, I have tried initializing to an infinite triangle but it slows down calculation pl (append pl sl) ; Vertex of Supertriangle are appended to the Point list sl (list np (+ np 1) (+ np 2)) ; sl now is a list of index into point list defining the supertriangle al (list (list xmax cp r sl)) ; Initialize the Active Triangle list ; al is a list that contains active triangles defined by 4 items: ; item 0: Xmax of points in triangle. ; item 1: List 2d coordinates of center of circle circumscribing triangle. ; item 2: Radius of above circle. ; item 3: List of 3 indexes to vertices defining the triangle ctr (list cp) ; added for Voronoi n -1 ; n is a counting index into Point List ) ; Begin insertion of points (repeat np (setq n (1+ n) ; Increment Index into Point List pt (nth n pl) ; Get one point from point list el nil) ; el list of triangles edges (repeat (length al) ; Loop to go through Active triangle list (setq tr (car al) ; Get one triangle from active triangle list. al (cdr al)) ; Remove the triangle from the active list. (cond ( (< (car tr) (car pt)) (setq tl (cons (cadddr tr) tl) ctr (cons (cadr tr) ctr)) ; added for voronoi ) ; This triangle inactive. We store it's 3 vertex in tl (Final triangle list). ( (< (distance pt (cadr tr)) (caddr tr)) ; pt is inside the triangle. (setq tr (cadddr tr) ; Trim tr to vertex of triangle only. a (car tr) ; Index of First point. b (cadr tr) ; Index of Second point. c (caddr tr)) ; Index of Third point. (setq el (vl-list* (list a b) (list b c) (list c a) el)) ; ((a b) (b c) (c a) (. .) (. .).....) ) ( t (setq l (cons tr l)) ) ; tr did not meet any cond so it remain active. We store it in the swap list ) ; End cond ) ; End repeat (length al) (setq al l ; Restore active triangle list from the temporary list. l nil) ; Clear the swap list to prepare for next insertion. ; Removes doubled edges, calculates circumcircles and add them to al (while el (if (or (member (reverse (car el)) el) (member (car el) (cdr el)) ) (setq el (vl-remove (reverse (car el)) el) el (vl-remove (car el) el)) (setq al (cons (getcircumcircle n (car el) pl) al) el (cdr el)) ) ) ) ; End repeat np ; We are done with points insertion. Any triangle left in al is added to tl (foreach tr al (setq tl (cons (cadddr tr) tl) ctr (cons (cadr tr) ctr)) ; Added for Voronoi ) ; Extract all triangle edges from tl and form edges list el (setq el nil) (foreach tr tl (setq el (vl-list* (list (caddr tr) (car tr)) (list (cadr tr) (caddr tr)) (list (car tr) (cadr tr)) el ) ) ) (setq el (reverse el)) ; Here let's draw the Voronoi Diagram (setq vl nil) (foreach e el (setq npos (vl-position (reverse e) el) epos (vl-position e el)) (if npos (setq vl (cons (list (/ npos 3) (/ epos 3)) vl)) (setq vl (cons (list (- (length ctr) 1) (/ epos 3)) vl)) ) ) (setq vor nil) (while vl (setq e (car vl) vl (vl-remove (reverse e) (cdr vl)) vor (cons e vor)) ) (mapcar (function (lambda (v) (list (nth (cadr v) ctr) (nth (car v) ctr) ) )) (cdddr ; Remove the edges of Supercircle (vl-sort vor (function (lambda (a b) (> (car a) (car b)) )) ) ) ) ) ) ) ;;************************************************************************************************; ;; Written by ElpanovEvgeniy ; ;; 17.10.2008 ; ;; Calculation of the centre of a circle and circle radius ; ;; for program triangulate ; ;; ; ;; Modified ymg june 2011 (renamed variables) ; ;; Modified ymg June 2013 to operate on Index ; ;;************************************************************************************************; (defun getcircumcircle (a el pl / b c c2 cp r ang vl pt) (setq pt (nth a pl) b (nth(car el) pl) c (nth(cadr el) pl) c2 (list (car c) (cadr c)) ; c2 is point c but in 2d vl (list a (car el) (cadr el))) (if (not (zerop (setq ang (- (angle b c) (angle b pt))))) (progn (setq cp (polar c2 (+ -1.570796326794896 (angle c pt) ang) (setq r (/ (distance pt c2) (sin ang) 2.0))) r (abs r)) (list (+ (car cp) r) cp r vl) ) ) ) (if (not (while (cond ( (not (setq ss (ssget (list (cons 0 "LWPOLYLINE"))))) (princ "\nNothing selected. Try again...\n") ) ( (/= (sslength ss) 2) (princ "\nSelect 2 polylines! Try again...\n") ) ( (and (setq ent1 (ssname ss 0)) (setq ent2 (ssname ss 1)) (setq pl (append (ent->pts ent1 100) (ent->pts ent2 100))) (setq ent1 (vlax-ename->vla-object ent1)) (setq ent2 (vlax-ename->vla-object ent2)) ) nil ; Stop loop ) ) ) ) (progn (setq s1 (_side ent1 (vlax-curve-getStartPoint ent2))) (setq s2 (_side ent2 (vlax-curve-getStartPoint ent1))) (setq vor (triangulate pl)) (setq vor (vl-remove-if-not (function (lambda (line) (and (equal s1 (_side ent1 (car line))) (equal s1 (_side ent1 (cadr line))) (equal s2 (_side ent2 (car line))) (equal s2 (_side ent2 (cadr line))) ) )) (vl-remove-if (function (lambda (x) (or (equal x (list nil nil)) (not (car x)) (not (cadr x))))) vor) ) ) (if (< (distance (vlax-curve-getStartPoint ent1) (vlax-curve-getEndPoint ent2)) (distance (vlax-curve-getEndPoint ent1) (vlax-curve-getEndPoint ent2)) ) (setq start (list (vlax-curve-getEndPoint ent1) (vlax-curve-getStartPoint ent1)) end (list (vlax-curve-getStartPoint ent2) (vlax-curve-getEndPoint ent2))) (setq start (list (vlax-curve-getStartPoint ent1) (vlax-curve-getEndPoint ent1)) end (list (vlax-curve-getStartPoint ent2) (vlax-curve-getEndPoint ent2))) ) (setq startEnd (mapcar (function (lambda (end1 end2) (caar (vl-sort (mapcar (function (lambda (line) (list line (+ (distance (car line) end1) (distance (car line) end2) (distance (cadr line) end1) (distance (cadr line) end2) ) ) )) vor ) (function (lambda (a b) (< (cadr a) (cadr b)) )) ) ) )) start end ) ) (_polyline ( (lambda (lst / rtn) ; Draw a line of the midpoints of voronoi lines (while (cdr lst) (setq rtn (cons (mapcar (function (lambda (a b) (* (+ a b) 0.5))) (car lst) (cadr lst) ) rtn ) ) (setq lst (cdr lst)) ) rtn ) (minlen vor startEnd) ) ) ) ) (princ) )

As for the code from my first attempt, I suppose the least I should do for any “child of mine” is to make sure it can have a functional life, no matter how cross-eyed it was born: you never abandon a child. So here I leave a new version of “GLAVCVS’ cross-eyed child”, fresh out of the hospital. ;| G L A V C V S C R O S S - E Y E D C H I L D - o - ************************* G L A V C V S ************************* *************************** F E C I T ***************************|; (defun c:creAxis (/ e e1 e2 l i? l1 l2 lr p p0 p1 p2 px pm abis lii pmi pmf pi1 pi2 pf1 pf2 pc1 pc2 li1 o dameInters+Prox ordena decide sustituye damePuntos) (defun dameInters+Prox (p0 a lp / p1 px pt1 pt2 dmin d pf) (setq pt1 (polar p0 a 1e8) pt2 (polar p0 (+ a PI) 1e8)) (foreach p lp (if p1 (if (setq px (inters pt1 pt2 p1 p)) (if dmin (if (< (setq d (distance px p0)) dmin) (setq dmin d pf px)) (setq dmin (distance px p0) pf px)) ) ) (setq p1 p) ) pf ) (defun ordena (po px pm / p0 lr) (foreach p lii (if (and p0 (inters po px p0 p)) (setq lr (append lr (list pm))) ) (setq p0 p lr (append lr (list p))) ) ) (if (and (setq e1 (car (entsel "\nSelect FIRST LWPOLYLINE..."))) (= (cdr (assoc 0 (setq l1 (entget e1)))) "LWPOLYLINE") (not (redraw e1 3))) (if (and (setq e2 (car (entsel "\nSelect SECOND LWPOLYLINE..."))) (= (cdr (assoc 0 (setq l2 (entget e2)))) "LWPOLYLINE") (not (redraw e2 3))) (progn (setq lp1 (reverse (foreach l l1 (if (= (car l) 10) (setq lr (cons (cdr l) lr)) lr))) lr nil lp2 (reverse (foreach l l2 (if (= (car l) 10) (setq lr (cons (cdr l) lr)) lr))) lr nil ) (cond ((= (rem (cdr (assoc 70 l1)) 2) 1) (setq lp1 (append lp1 (list (car lp1) (cadr lp1) (caddr lp1)))) ) ((equal (car lp1) (last lp1)) (setq lp1 (append lp1 (list (cadr lp1) (caddr lp1)))) ) (T (setq pmi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (car lp1) (setq pc1 (vlax-curve-getClosestPointTo e2 (car lp1)))) pmf (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (last lp1) (setq pc2 (vlax-curve-getClosestPointTo e2 (last lp1)))) ) ) ) (cond ((= (rem (cdr (assoc 70 l2)) 2) 1) (if pmi (progn (foreach p (append lp2 (list (car lp2))) (if (or (equal p pmi 1e-4) (equal p pmf 1e-4)) (setq l (if l (not (setq lr (append l (list p)))) (list (list p)))) (if l (setq l (append l (list p)))) ) ) (setq lp2 lr lr nil l nil) ) (setq lp2 (append lp2 (list (car lp2) (cadr lp2)))) ) ) ((equal (car lp2) (last lp2)) (if pc1 (progn (foreach p lp2 (if (or (equal p pc1 1e-4) (equal p pc2 1e-4)) (setq l (if l (not (setq lr (append l (list p)))) (list (list p)))) (if l (setq l (append l (list p)))) ) ) (setq lp2 lr lr nil l nil) ) (setq lp2 (append lp2 (list (cadr lp2)))) ) ) ) (redraw e1 4) (redraw e2 4) (foreach lp (list lp1 lp2) (foreach l lp (if p1 (if p2 (setq abis (+ (/ (+ (angle p1 p2) (angle p2 l)) 2) (/ PI 2.)) px (dameInters+Prox p2 abis (if o lp1 lp2)) lr nil pm (if px (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p2 px)) lii (if o (if pm (ordena p2 px pm) lii) (if px (append lii (list pm)) lii)) p1 p2 p2 l ) (setq p2 l) ) (setq p1 l) ) ) (if pmi (setq lii (append (list pmi) lii (list pmf)))) (setq p1 nil p2 nil lr nil o T) ) ) ) ) (entmake (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbPolyline") (70 . 0) (60 . 0)) (list (cons 90 (length lii))) (mapcar '(lambda (a) (cons 10 a)) lii))) (princ) )

Here's a simpe solution that doesn't use LISP. Change the elevation of one of the polylines to 1.0 then use the loft command to create asurface. Section the resulting surface with an XY plane at 0,0,0.5.

did a little cleaning & tweaking and added a (grdraw) background to give it just a tiny bit more spunk ... enjoy ;;; RlxGrMenu - 2025-07-09 - Just a funny / basic / tiny 'toolbar' ;;; It draws a column on the right of your screen with 12 rows. ;;; Config is not working yet and I'm not sure it's worth the effort because its only meant as a lisp launcher. ;;; Quit by click on QUIT in toolbar or by typing Q , q or space, zoom in / out with +/-/z ;;; I've run a little out of button-space so wanted an out of the box solution to this problem. ;;; this is just a way to run my 10 most used lisp routines, nothing more , nothing less. ;;; Substitute the names in app-list (setq app-list (list "LC" "VT"...) with names from your own favorite apps ;;; Apps (lisps) have to be in search path so (findfile (strcat "MyApp" ".lsp") should work. ;;; Also apps should not be self executing and the start command should be same as app name. ;;; If your app is named "MyApp" this routine loads the app if found and starts it with (eval (read (strcat "C:" "Myapp"))) ;;; have fun ;;; ------------------------------ ;;; ;;; |S1 S2| ;;; ;;; | -------------- ----- [a]| ;;; ;;; | |E1 E2| [b]| ;;; ;;; | | | [c]| ;;; ;;; | | | [d]| ;;; ;;; | |E3 E4| [e]| ;;; ;;; | -------------------- [f]| ;;; ;;; |S3 S4| ;;; ;;; ------------------------------ ;;; ;;; (count_calcula) : run time values for viewsize / viewcenter etc ;;; values are effected by resize window : vc , vs , ss , x+ , x- , y+ , y- , P1-P4 ;;; screen corner points : S1 = (x- y+) , S2 (x+ y+) , S3 (x- y-) , S4 (x+ y-) ;;; extents corner points : E1 - E5 extmin / extmax ;;; viewsize : vs - height current viewport (drawing units) (i.e. 300 / 386 after resize) ;;; screen size : ss (1187 532) (pixels) after max acad window : vs = 386 , ss = (1840 685) ;;; - 12 rows, 1-10 for user , 11 for config , 12 for exit ;;; - height each row = viewsize / 12, row width = 2 x row height ;;; cell-ip = (list (- (fix x+) cell-size) (fix y+)) ;;; vector draw cell-ip -> cell-size<0, (* cell-size 12)<270 , cell-size<180 , (* cell-size 12)<90 (defun draw_menu ( / ip-x ip-y cell-h cell-w cell-ul cell-ll cell-ur cell-lr y-list ctr-x app-list app gr-loop tblc tbtc tbbc start-viewsize) (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare" "Config" "Quit")) ;;; toolbar line color / toolbar text color / toolbar background color (setq gr-loop T tblc 7 tbtc 7 tbbc 8) ;;; when zooming in/out it messes up back ground fill so have to compensate for that (setq start-viewsize (getvar "viewsize")) (redraw_menu) ;;; launch app (if app (RlxGrMenu_Start_App app)) ) (defun redraw_menu () (redraw) ;;; get live screen data (count_calcula) (setq cell-h (/ (- y+ y-) 12) cell-w (* cell-h 2)) ;;; corner points (setq cell-ul (list (- x+ cell-w) y+) cell-ur (list x+ y+) cell-ll (list (- x+ cell-w) y-) cell-lr (list x+ y-)) ;;; get y values for all horizontal separators (setq x-list (list (car cell-ll) (car cell-lr)) y-list (gnl- (- (fix y+) cell-h) 11 cell-h)) ;;; fill the backgrounds (setq yy y-) (while (< yy y+) (grdraw (list (car cell-ll) yy) (list (car cell-lr) yy) tbbc) ;;; next y depends on zoom factor (viewsize) , 0.25 is emperical, bigger means bigger linespacing (setq yy (+ yy (* 0.25 (/ (getvar "viewsize") start-viewsize)))) ) ;;; draw the outlines (grdraw cell-ll cell-ul tblc)(grdraw cell-ul cell-ur tblc)(grdraw cell-ur cell-lr tblc)(grdraw cell-lr cell-ll tblc) ;;; drawn separators (foreach y y-list (grdraw (list (car cell-ll) y) (list (car cell-lr) y) tblc)) ;;; label the cell (setq ctr-x (+ (car cell-ll) (* cell-w 0.5))) (mapcar '(lambda (s y)(grtxt (strcase s) (list ctr-x (+ y (* cell-h 0.5))) tbtc 0 "M")) app-list (append y-list (list (- (last y-list) cell-h)))) (if gr-loop (RlxGrMenu_Get_Cell_ID x-list y-list)) ) ;;; fill cell with cell background color , use offset of 0.5 unit so outlines remain visible (defun fill_cell (x y w h / x2 y2 w2 h2 x3) (setq x2 (+ x 0.5) y2 (+ y 0.5) w2 (- w 1) h2 (- h 1) x3 (+ x2 w2)) ;(repeat (* (fix h2) 2) (grdraw (list x2 y2) (list x3 y2) tbbc)(setq y2 (+ y2 0.5))) (while (< y2 (cadr cell-ul)) (grdraw (list x2 y2) (list x3 y2) tbbc)(setq y2 (+ y2 0.5))) ) ;;; (re) calculate display parameters (count_calcula) (defun count_calcula () (setq vc (getvar "VIEWCTR") vs (getvar "VIEWSIZE") ss (getvar "SCREENSIZE") dx (* vs (/ (car ss) (cadr ss)) 0.5) dy (* vs 0.5) x- (- (car vc) dx) y- (- (cadr vc) dy) x+ (+ (car vc) dx) y+ (+ (cadr vc) dy) ip (getvar "viewctr") vc-x (car ip) vc-y (cadr ip) txt-h (/ (getvar "VIEWSIZE") 100.0))) ;;; (getvar "extmin") (getvar "extmax") (setq dvx (- x+ x-) dvy (- y+ y-)) (defun screen_res (/ s i is) (setq s (vlax-invoke (vlax-create-object "WbemScripting.SWbemLocator") 'ConnectServer nil nil nil nil nil nil nil) is (vlax-invoke s 'ExecQuery "SELECT CurrentHorizontalResolution, CurrentVerticalResolution FROM Win32_VideoController")) (vlax-for i is (vlax-get i 'CurrentHorizontalResolution))) ;;; generate number (gnum 1 5) -> '(1 2 3 4 5) (defun gnum (s e / i l) (and (numberp s)(numberp e)(setq i s)(while (<= i e)(setq l (cons i l) i (1+ i)))) (reverse l)) ;;; i = startnumber n = number of numbers , d = difference (gnl- 100 6 12) -> (100 88 76 64 52 40) (defun gnl- (i n d / l) (setq l (list i))(repeat (1- n)(setq l (cons (setq i (- i d)) l)))(reverse l)) ;;; found this old lisp (grtxt.lsp) , don't know author but all credits are for this human from earth ;;; text string / coordinate point / color / angle justificationz ;;; *** UPPER CASE ONLY *** (grtxt (STRCASE "Rob") (getvar "viewctr") 1 0 "M") (defun grtxt (ts cp cl a j / vp ltb i xp z c p1 p2 lp ld n al) ;;; vertex points (setq vp '(( 1 ( 0.50 0.25))( 2 ( 0.50 0.55))( 3 ( 0.50 0.85))( 4 ( 0.50 1.00))( 5 ( 0.25 1.00)) ( 6 ( 0.00 1.00))( 7 (-0.25 1.00))( 8 (-0.50 1.00))( 9 (-0.50 0.85))(10 (-0.50 0.55)) (11 (-0.50 0.25))(12 (-0.50 0.10))(13 (-0.25 0.10))(14 ( 0.00 0.10))(15 ( 0.25 0.10)) (16 ( 0.50 0.10))(17 ( 0.50 -0.05))(18 ( 0.50 -0.45))(19 ( 0.50 -0.85))(20 ( 0.50 -1.00)) (21 ( 0.25 -1.00))(22 ( 0.00 -1.00))(23 (-0.25 -1.00))(24 (-0.50 -1.00))(25 (-0.50 -0.85)) (26 (-0.50 -0.40))(27 (-0.50 -0.05))(30 ( 0.35 0.85))(31 (-0.35 0.85))(32 (-0.35 -0.85)) (33 ( 0.35 -0.85))(40 ( 0.25 0.35))(41 (-0.25 0.35))(42 ( 0.25 -0.15))(43 (-0.25 -0.15)) (44 ( 0.00 0.45))(45 ( 0.00 -0.25))(50 ( 0.30 0.20))(51 ( 0.30 0.35))(52 ( 0.20 0.35)) (53 ( 0.20 0.20))(54 ( 0.30 0.10))(55 ( 0.30 -0.10))(56 ( 0.20 -0.10))(57 ( 0.20 0.10)) (60 (-0.30 0.20))(61 (-0.30 0.35))(62 (-0.20 0.35))(63 (-0.20 0.20))(64 (-0.30 0.10)) (65 (-0.30 -0.10))(66 (-0.20 -0.10))(67 (-0.20 0.10)))) ;;; letter table (setq ltb '(("A" 24 9 7 5 3 20 16 12) ("B" 12 15 1 3 5 8 24 21 19 17 15) ("C" 3 5 7 9 25 23 21 19) ("D" 3 5 8 24 21 19 3) ("E" 4 8 12 15 12 24 20) ("F" 4 8 12 15 12 24) ("G" 3 5 7 9 25 23 21 19 16 14) ("H" 20 -4 8 -24 16 12) ("I" 7 5 6 22 23 21) ("J" 4 19 21 23 25) ("K" 8 24 12 13 4 13 20) ("L" 8 24 20) ("M" 24 8 14 4 20) ("N" 24 8 20 4) ("O" 3 5 7 9 25 23 21 19 3) ("P" 12 15 1 3 5 8 24) ("Q" 3 5 7 9 25 23 21 19 3 -19 20 45) ("R" 20 14 12 15 1 3 5 8 24) ("S" 3 5 7 9 11 13 15 17 19 21 23 25) ("T" 4 8 6 22) ("U" 8 25 23 21 19 4 20) ("V" 8 22 4) ("W" 8 23 14 21 4) ("X" 4 -24 8 20) ("Y" 8 14 22 14 4) ("Z" 8 4 24 20) ("0" 3 5 7 9 25 23 21 19 -3 4 24) ("1" 31 7 6 22 21 23) ("2" 9 7 5 3 1 15 13 27 24 20) ("3" 9 7 5 3 1 15 13 15 17 19 21 23 25) ("4" 8 12 16 15 5 21) ("5" 4 8 12 15 17 19 21 23 25) ("6" 3 5 7 9 25 23 21 19 17 15 12) ("7" 8 4 22) ("8" 3 5 7 9 11 13 27 25 23 21 19 17 15 13 15 1 3) ("9" 25 23 21 19 3 5 7 9 11 13 16) ("<" 4 12 20) (">" 8 16 24) ("," 33 21) ("." 19 20 21 33 19) ("\'" 4 30) ("\"" 4 -30 7 31) (";" 50 51 52 53 -50 54 55 56 57 55 45) (":" 50 51 52 53 -50 54 55 56 57 55) ("\\" 8 20) ("/" 4 24) ("?" 11 10 7 5 2 1 45 22) ("|" 6 -44 45 22) ("+" 44 -45 13 15) ("=" 40 -41 43 42) ("-" 13 15) ("_" 20 24) (")" 6 2 18 22) ("(" 6 10 26 22) ("*" 40 -43 41 -42 45 44) ("&" 21 31 7 6 26 25 23 16) ("^" 10 6 2) ("%" 57 54 55 56 -57 63 60 61 62 -63 5 24) ("$" 3 5 7 9 11 13 15 17 19 21 23 25 -26 22 6) ("#" 24 -6 22 -4 1 -11 17 27) ("@" 42 15 40 44 41 13 43 45 42 17 3 5 7 9 25 23 21 19) ("!" 6 -45 22 22) ("~" 9 31 44 40 2) ("`" 8 31) ("[" 6 8 24 22) ("]" 6 4 20 22) ("{" 6 7 41 12 43 23 22) ("}" 6 5 40 16 42 21 22) (""))) ;;; text height (setq z (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")) 0.2)) (cond ;;; left justification ((eq (strcase (substr j 1 1)) "L") (setq xp (list (+ (car cp) z) (cadr cp)) i 1)) ;;; middle justification ((eq (strcase (substr j 1 1)) "M") (setq xp (list (- (car cp) (* z (strlen ts) 0.5)) (cadr cp)) i 1)) ;;; right justification ((eq (strcase (substr j 1 1)) "R") (setq xp (list (- (car cp) (* z (strlen ts) 1.5)) (cadr cp)) i 1)) ) (repeat (strlen ts) ;;; each charachter / line point list / letter point def (setq c (substr ts i 1) lp '() ld (cdr (assoc c ltb))) (while (> (length ld) 1) (setq p1 (cadr (assoc (abs (nth 0 ld)) vp)) p2 (cadr (assoc (abs (nth 1 ld)) vp)) p1 (mapcar '* (list z z) p1) p2 (mapcar '* (list z z) p2) p1 (mapcar '+ xp p1) p2 (mapcar '+ xp p2) lp (append lp (list (if (minusp (nth 0 ld)) 0 cl) p1 p2)) ld (cdr ld)) ) ;;; add rotation angle (setq n 0 al nil) (repeat (/ (length lp) 3) (setq al (cons (nth n lp) al) al (cons (polar cp (+ a (angle cp (nth (+ n 1) lp))) (distance cp (nth (+ n 1) lp))) al) al (cons (polar cp (+ a (angle cp (nth (+ n 2) lp))) (distance cp (nth (+ n 2) lp))) al)) (setq n (+ n 3)) ) (and al (grvecs (reverse al))) (setq xp (list (+ (car xp) (* z 1.5)) (cadr xp)) i (1+ i)) ) (prin1) ) ;;; probably won't need tracking mode (cut-copy-paste you know...) (defun RlxGrMenu_Get_Cell_ID (xl yl / inp dev tpt prev-tpt mark-current-tracking-point cell-id prev-cell-id prev-view-size cur-view-size rtn) (princ "\nEsc/Q/Rmouse to cancel, zoom with E(extend), Z(oom) or + / -") (setq prev-view-size (getvar "viewsize")) (while gr-loop (setq cur-view-size (getvar "viewsize")) (setq inp (vl-catch-all-apply 'grread (list T 8 1))) (if (vl-catch-all-error-p inp) (progn (setq gr-loop nil inp nil)(redraw)) (progn (setq dev (car inp) tpt (cadr inp)) (cond ;;; space , q or Q (Quit) ((and (= dev 2) (member (last inp) '(32 113 81))) (redraw)(setq gr-loop nil) ) ;;; point selection (3 (221.882 173.853 0.0)) ((= dev 3) (if (setq rtn (find_cell tpt xl yl)) (progn ;(alert (setq app (nth (1- (atoi rtn)) app-list))) (princ (strcat "\nLaunching : " (setq app (nth (1- (atoi rtn)) app-list)))) (setq gr-loop nil) ) ) ) ;;; device tracking point (probably don't need tracking mode) ((= dev 5) ;;; if mouse moved (if (or (/= (car prev-tpt)(car tpt)) (/= (cadr prev-tpt)(cadr tpt))) (progn (setq prev-tpt tpt ))) (if (not (equal cur-view-size prev-view-size)) (progn (setq prev-view-size cur-view-size) (redraw_menu) ) ) ) ; user pressed E of e ((member inp '((2 69)(2 101))) (command "zoom" "e")) ; user clicked R-mouse button, pressed enter or space (done selecting) ((or (equal (car inp) 25)(member inp '((2 13)(2 32)))) (setq gr-loop nil)) ; user pressed + ((equal inp '(2 43)) (vl-cmdf "zoom" "2x")) ; user pressed - ((equal inp '(2 45)) (vl-cmdf "zoom" ".5x")) ; user pressed z or Z ((member inp '((2 122)(2 90))) (vl-cmdf "'zoom" "")) ) ) ) ) (princ) ) ;;; pt = point , xl = x-list , yl = y-list ;;; scribble : (< 1 2 3) , (> 3 2 1) , (cdr (vl-sort '(1 2 3 4 5) '>)) -> '(4 3 2 1) (defun find_cell ( pt xl yl / ptx pty y-lst l n hit) (setq n nil hit nil ptx (car pt) pty (cadr pt) y-list (vl-sort (append yl (list 0)) '>)) (if (< (car xl) ptx (cadr xl)) (mapcar '(lambda (y)(if (and (not hit) (> pty y)) (setq hit T n (vl-position y y-list)))) y-list)) (if n (itoa (1+ n))) ) ;;; program assumes no self starting routines and start command is "C:" + app name (defun RlxGrMenu_Start_App (app / fn) (cond ((setq fn (findfile (strcat app ".lsp"))) (redraw)(load fn)(eval (read (strcat "(C:" app ")")))) ((wcmatch (strcase app) "QUIT")(princ "\nBye bye")(redraw)) ((wcmatch (strcase app) "CONFIG")(princ "\nUnder construction")(redraw)) (t (redraw)(princ (strcat "\nUnable to load " (vl-princ-to-string app) " ...bye"))) ) ) ;;; future... ;;; RlxGrMenu - Rlx Jul/25 (defun RlxGrMenu_future ( / ;;; global variables scr-res cell-rows cell-cols cell-col cell-id app-list ;;; display parameters like viewctr/viewsize/screensize (count_calcula) vc vs ss dx dy x- x+ y- y+ ip vc-x vc-y txt-h ;;; registry variables RlxGrMenu-nof-cell-rows RlxGrMenu-nof-cell-cols RlxGrMenu-app-list ) ;;; mostly not used because for now I just just one column with 10 rows (setq scr-res (screen_res) rows 3 cols 3 cell-col 141 cell-id 1) (count_calcula) (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare")) (RlxGrMenu_Init) (RlxGrMenu_Doit) (RlxGrMenu_Exit) (princ) ) (defun RlxGrMenu_Init ()(princ "\nUnder construction - RlxGrMenu_Init ")) (defun RlxGrMenu_Doit ()(princ "\nUnder construction - RlxGrMenu_Doit ")) (defun RlxGrMenu_Exit ()(princ "\nUnder construction - RlxGrMenu_Exit ")) (defun c:RlxGrMenu ()(draw_menu)) (defun c:t1 ()(draw_menu)) (defun t1 ()(draw_menu))

however... quite aggressive asking for the credit here today. Nicer ways to go "Hey, this was originally my code, can you credit me" and perhaps if possible the link to the original code to help the OP out. Code gets shared, the links and credits lost. Always good practice to add links to the sources and credits in case there are thing you want to go back and understand more from any discussions. Having said that though, upload code, you have no control of it's use and I am not sure I'd want credited with a base code that is mine and then heavily modified, or just a snippet of my code included in something larger without me doing checks and testing.

Another for fun - should work in all UCS/Views: (defun c:itsatrap ( / hgt len ocs off pt1 pt2 ) (if (and (setq pt1 (getpoint "\nInsertion point: ")) (setq len (getdist "\nLength of base: " pt1)) (setq hgt (getdist "\nHeight: " pt1)) (setq ocs (trans '(0 0 1) 1 0 t) pt2 (cons (+ (car pt1) len) (cdr pt1)) off (* hgt (/ (sqrt 3) 3)) ) ) (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) (cons 10 (trans pt1 1 ocs)) (cons 10 (trans pt2 1 ocs)) (cons 10 (trans (list (+ (car pt2) off) (+ (cadr pt2) hgt) (caddr pt2)) 1 ocs)) (cons 10 (trans (list (- (car pt1) off) (+ (cadr pt1) hgt) (caddr pt1)) 1 ocs)) (cons 210 ocs) ) ) ) (princ) )

Using a voronoi diagram (code by ymg, ElpanovEvgeniy and Marko Ribar) You can get some very good reference points. Just have to find a way to get rid of all the 'branches' and then take al the midpoints of every line to get a good centerline. centerline-voronoi.lsp

Calculating an axis using angle bisectors a) Attempt number 1 (it was my first impulse, but I came up with a better one later) Advantages: - Pure LISP: doesn't depend on Express Tools, - It's faster Disadvantages: - The result isn't as good as @GP_'s "c:CPL" - It only accepts LWPOLYLINES and ignores arcs Basically, the approach is to obtain angle bisectors on each polyline, extend them to the other reference polyline, and use their midpoints. The result is acceptably good, but not as accurate as c:CPL. (defun c:creAxis (/ e e1 e2 l1 l2 lr p p0 p1 p2 px pm abis lii pmi pfi pi1 pi2 pf1 pf2 dameInters+Prox ordena) (defun dameInters+Prox (p0 a lp / p1 px pt1 pt2 dmin d pf) (setq pt1 (polar p0 a 1e8) pt2 (polar p0 (+ a PI) 1e8)) (foreach p lp (if p1 (if (setq px (inters pt1 pt2 p1 p)) (if dmin (if (< (setq d (distance px p0)) dmin) (setq dmin d pf px)) (setq dmin (distance px p0) pf px)) ) ) (setq p1 p) ) pf ) (defun ordena (pr lp / d dmin ps lr) (while lp (foreach p lp (if dmin (if (< (setq d (distance p pr)) dmin) (setq dmin d ps p) ) (setq dmin (distance p pr) ps p) ) ) (setq dmin nil pr ps lp (vl-remove ps lp) lr (append lr (list ps))) ) ) (if (and (setq e1 (car (entsel "\nSelect first LWPOLYLINE..."))) (= (cdr (assoc 0 (setq l1 (entget e1)))) "LWPOLYLINE") (not (redraw e1 3))) (if (and (setq e2 (car (entsel "\nSelect second LWPOLYLINE..."))) (= (cdr (assoc 0 (setq l2 (entget e2)))) "LWPOLYLINE") (not (redraw e2 3))) (progn (setq lp1 (reverse (foreach l l1 (if (= (car l) 10) (setq lr (cons (cdr l) lr)) lr))) lr nil; lp2 (reverse (foreach l l2 (if (= (car l) 10) (setq lr (cons (cdr l) lr)) lr))) lr nil; ) (if (< (distance (setq pi1 (cdr (assoc 10 l1))) (setq pi2 (cdr (assoc 10 l2)))) (distance pi1 (setq pf2 (cdr (assoc 10 (reverse l2)))))) (setq pmi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) pi1 pi2) pfi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (setq pf1 (cdr (assoc 10 (reverse l1)))) pf2) ) (setq pmi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) pi1 pf2) pfi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (cdr (assoc 10 (reverse l1))) pi2) ) ) (redraw e1 4) (redraw e2 4) (foreach l l1 (if (= (car l) 10) (if p1 (if p2 (setq abis (+ (/ (+ (angle p1 p2) (angle p2 (cdr l))) 2) (/ PI 2.)) x (princ) px (dameInters+Prox p2 abis lp2) lr nil pm (if px (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p2 px)) lii (if px (append lii (list pm)) lii) p1 p2 p2 (cdr l) ) (setq p2 (cdr l)) ) (setq p1 (cdr l)) ) ) ) (setq p1 nil p2 nil lr nil) (foreach l l2 (if (= (car l) 10) (if p1 (if p2 (setq abis (+ (/ (+ (angle p1 p2) (angle p2 (cdr l))) 2.) (/ PI 2.)) px (dameInters+Prox p2 abis lp1); pm (if px (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p2 px) (princ) ) lii (if px (append lii (list pm)) lii); p1 p2 p2 (cdr l) ) (setq p2 (cdr l)) ) (setq p1 (cdr l)) ) ) ) (setq lii (append (list pmi) (ordena pmi lii) (list pfi))) ) ) ) (entmake (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbPolyline") (70 . 0) (60 . 0)) (list (cons 90 (length lii))) (mapcar '(lambda (a) (cons 10 a)) lii))) (princ) ) PS: It seems to work well, but I haven't tested it extensively. As I said at the beginning, there's a better approach, using angle bisectors, which I'll publish later.

Long time I'm nothing written in Lisp. So, I hoppe it will serve you. Also, you can saw a short video how it works. The code: (prompt "\nTo run a LISP type: yval") (princ) (defun c:yval ( / old_osmode pline spt ept spt_pline ept_pline datum_line yval_datum_line yval_start_pline yval_end_pline txt_position ang_spt_pline ang_ept_pline datum_value intersecting_lines len i int_pt_pline int_pt_datum_line dist yval_position ang) (setq old_osmode (getvar 'osmode)) (setq pline (car (entsel "\nSelect Polyline to get an Elevation:"))) (while (or (equal pline nil) (not (equal "LWPOLYLINE" (cdr (assoc 0 (entget pline)))))) (prompt "\nSelected entity must be LWPOLYLINE. Try again...\n") (setq pline (car (entsel "\nSelect Polyline to get an Elevation:"))) ) (setq spt_pline (vlax-curve-getStartPoint pline) ept_pline (vlax-curve-getEndPoint pline) ) (if (> (car spt_pline) (car ept_pline)) (progn (command-s "_reverse" pline "") (setq spt_pline (vlax-curve-getStartPoint pline) ept_pline (vlax-curve-getEndPoint pline) ) ) ) (setq datum_line (car (entsel "\nSelect Datum Line:"))) (while (or (equal datum_line nil) (not (equal "LINE" (cdr (assoc 0 (entget datum_line)))))) (prompt "\nSelected entity must be LINE. Try again...\n") (setq datum_line (car (entsel "\nSelect Datum Line:\n"))) ) (setq yval_datum_line (cadr (vlax-curve-getStartPoint datum_line)) yval_start_pline (- (cadr spt_pline) yval_datum_line) yval_end_pline (- (cadr ept_pline) yval_datum_line) ) (setq txt_position (getpoint "\nPick the lower-left corner of the box for elevation value:\n")) (setvar 'osmode 0) (setq datum_value (car (entsel "\nSelect Datum value:"))) (if (equal "MTEXT" (cdr (assoc 0 (entget datum_value)))) (setq datum_value (LM:UnFormat (cdr (assoc 1 (entget datum_value))) T)) (setq datum_value (cdr (assoc 1 (entget datum_value)))) ) (setq ang_spt_pline (angle (setq yval_position_one (list (car spt_pline) (+ (cadr txt_position) 0.1) (caddr txt_position))) spt_pline) ang_ept_pline (angle (setq yval_position_two (list (car ept_pline) (+ (cadr txt_position) 0.1) (caddr txt_position))) ept_pline) ) (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 1 (rtos (+ yval_start_pline (atof datum_value)) 2 3)) (cons 10 yval_position_one) (cons 11 yval_position_one) (cons 40 0.35) (cons 72 0) (cons 73 2) (cons 50 ang_spt_pline))) (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 1 (rtos (+ yval_end_pline (atof datum_value)) 2 3)) (cons 10 yval_position_two) (cons 11 yval_position_two) (cons 40 0.35) (cons 72 0) (cons 73 2) (cons 50 ang_ept_pline))) (princ "\nSelect intersecting lines:") (setq intersecting_lines (ssget (list (cons 0 "LINE") (cons 8 "DATUM-GRID"))) len (sslength intersecting_lines) i 0 ) (while (< i len) (setq int_pt_pline (vlax-safearray->list (vlax-variant-value (vla-IntersectWith (vlax-ename->vla-object pline) (vlax-ename->vla-object (ssname intersecting_lines i)) acExtendNone))) int_pt_datum_line (vlax-safearray->list (vlax-variant-value (vla-IntersectWith (vlax-ename->vla-object datum_line) (vlax-ename->vla-object (ssname intersecting_lines i)) acExtendNone))) dist (distance int_pt_pline int_pt_datum_line) yval_position (list (car int_pt_pline) (+ (cadr txt_position) 0.1) (caddr txt_position)) ang (angle yval_position int_pt_pline) i (1+ i) ) (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 1 (rtos (+ dist (atof datum_value)) 2 3)) (cons 10 yval_position) (cons 11 yval_position) (cons 40 0.35) (cons 72 0) (cons 73 2) (cons 50 ang_spt_pline))) ) (setvar 'osmode old_osmode) (prompt "\nAn elevation values were added!") (princ) ) ;;-------------------=={ UnFormat String }==------------------;; ;; ;; ;; Returns a string with all MText formatting codes removed. ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; str - String to Process ;; ;; mtx - MText Flag (T if string is for use in MText) ;; ;;------------------------------------------------------------;; ;; Returns: String with formatting codes removed ;; ;;------------------------------------------------------------;; (defun LM:UnFormat ( str mtx / _replace rx ) (vl-load-com) (defun _replace ( new old str ) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new) ) (if (setq rx (vlax-get-or-create-object "VBScript.RegExp")) (progn (setq str (vl-catch-all-apply (function (lambda ( ) (vlax-put-property rx 'global actrue) (vlax-put-property rx 'multiline actrue) (vlax-put-property rx 'ignorecase acfalse) (foreach pair '( ("\032" . "\\\\\\\\") (" " . "\\\\P|\\n|\\t") ("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]") ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);") ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}") ("$1" . "[\\\\]({)|{") ) (setq str (_replace (car pair) (cdr pair) str)) ) (if mtx (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str)) (_replace "\\" "\032" str) ) ) ) ) ) (vlax-release-object rx) (if (null (vl-catch-all-error-p str)) str ) ) ) ) The short video: YVAL.mp4 Best regards.

I wanted more buttons but ran out of space so just created an alternative reallity for myself. It's very basic / simple and still a work in progress but as usual time is not on my side especially now my boss in away for 4 weeks and he probably was afraid I would get bored and start to play with myself so he left me with a load of work. Update : because this routine uses grread you can't run any other (transparent) commands. Thats why I added 'hot' keys for zoom. E for extents, Z for zoom , + & - for zooming in & out. Maybe it's useful , maybe it's not...bite me. ;;; RlxGrMenu - 2025-07-09 - Just a funny / very basic little 'toolbar' ;;; It draws a column with 12 rows. Config is not working yet, quit by click or by typing Q or q. ;;; I've run a little out of button-space so wanted an out of the box solution to this problem. ;;; this is just a way to run my 10 most used lisp routines, nothing more , nothing less. ;;; Substitute the names in app-list (setq app-list '("LC" "VT" ...) with names from your own favorite apps ;;; apps have to be in search path so (findfile (strcat "MyApp" ".lsp") should work'. ;;; Also app should not be self executing and the start command should be same as app name ;;; If your app is named "MyApp" this routine loads app if found and starts it with (eval (read (strcat "C:" "Myapp"))) ;;; have fun ;;; ------------------------------ ;;; ;;; |S1 S2| ;;; ;;; | -------------- ----- [a]| ;;; ;;; | |E1 E2| [b]| ;;; ;;; | | | [c]| ;;; ;;; | | | [d]| ;;; ;;; | |E3 E4| [e]| ;;; ;;; | -------------------- [f]| ;;; ;;; |S3 S4| ;;; ;;; ------------------------------ ;;; ;;; (count_calcula) : ;;; values are effected by resize window : vc , vs , ss , x+ , x- , y+ , y- , P1-P4 ;;; screen corner points : S1 = (x- y+) , S2 (x+ y+) , S3 (x- y-) , S4 (x+ y-) ;;; extents corner points : E1 - E5 extmin / extmax ;;; viewsize : vs - height current viewport (drawing units) (i.e. 300 / 386 after resize) ;;; screen size : ss (1187 532) (pixels) after max acad window : vs = 386 , ss = (1840 685) ;;; - 12 rows, 1-10 for user , 11 for confid , 12 for exit ;;; - height each row = (fix (/ (- y+ y-) 12)) , for example 25 ;;; - row width = row height , lets call it cell-size ;;; cell-ip = (list (- (fix x+) cell-size) (fix y+)) ;;; vector draw cell-ip -> cell-size<0, (* cell-size 12)<270 , cell-size<180 , (* cell-size 12)<90 (defun draw_menu ( / ip-x ip-y cell-h cell-w cell-ul cell-ll cell-ur cell-lr y-list ctr-x app-list app gr-loop tblc tbtc) (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare" "Config" "Quit")) (setq gr-loop T tblc 7 tbtc 7) ;;; toolbar line color / toolbar text colot (redraw_menu) ;;; launch app (if app (RlxGrMenu_Start_App app)) ) (defun redraw_menu () (redraw) ;;; get live screen data (count_calcula) ;(setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare" "Config" "Quit")) ;(setq cell-h (fix (/ (- y+ y-) 12)) cell-w (* cell-h 2)) ;;;; corner points ;(setq cell-ul (list (- (fix x+) cell-w) (fix y+)) cell-ur (list (fix x+) (fix y+)) ; cell-ll (list (- (fix x+) cell-w) (fix y-)) cell-lr (list (fix x+) (fix y-))) (setq cell-h (/ (- y+ y-) 12) cell-w (* cell-h 2)) ;;; corner points (setq cell-ul (list (- x+ cell-w) y+) cell-ur (list x+ y+) cell-ll (list (- x+ cell-w) y-) cell-lr (list x+ y-)) ;;; draw the outlines (grdraw cell-ll cell-ul tblc)(grdraw cell-ul cell-ur tblc)(grdraw cell-ur cell-lr tblc)(grdraw cell-lr cell-ll tblc) ;;; get y values for all horizontal separators (setq x-list (list (car cell-ll) (car cell-lr)) y-list (gnl- (- (fix y+) cell-h) 11 cell-h)) (foreach y y-list (grdraw (list (car cell-ll) y) (list (car cell-lr) y) tblc)) ;;; label the cell (setq ctr-x (+ (car cell-ll) (* cell-w 0.5))) (mapcar '(lambda (s y) (grtxt (strcase s) (list ctr-x (+ y (* cell-h 0.5))) tbtc 0 "M")) app-list (append y-list (list (- (last y-list) cell-h)))) (if gr-loop (RlxGrMenu_Get_Cell_ID x-list y-list)) (princ) ) ;;; (re) calculate display parameters (count_calcula) (defun count_calcula () (setq vc (getvar "VIEWCTR") vs (getvar "VIEWSIZE") ss (getvar "SCREENSIZE") dx (* vs (/ (car ss) (cadr ss)) 0.5) dy (* vs 0.5) x- (- (car vc) dx) y- (- (cadr vc) dy) x+ (+ (car vc) dx) y+ (+ (cadr vc) dy) ip (getvar "viewctr") vc-x (car ip) vc-y (cadr ip) txt-h (/ (getvar "VIEWSIZE") 100.0))) ;;; (getvar "extmin") (getvar "extmax") (setq dvx (- x+ x-) dvy (- y+ y-)) (defun screen_res (/ s i is) (setq s (vlax-invoke (vlax-create-object "WbemScripting.SWbemLocator") 'ConnectServer nil nil nil nil nil nil nil) is (vlax-invoke s 'ExecQuery "SELECT CurrentHorizontalResolution, CurrentVerticalResolution FROM Win32_VideoController")) (vlax-for i is (vlax-get i 'CurrentHorizontalResolution))) ;;; get aspect ratio current screen (defun asp_rat () (rtos (* 1.5 (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))))) ;;; determine status caps lock for when typing filter (even though filter uses strcase) (defun case (s) (cond ((null s) "") ((not (eq (type s) 'STR)) "") ((null capslock) s) (t (if (= (acet-sys-keystate 20) 0) (strcase s t) (strcase s))))) ;;; generate number (gnum 1 5) -> '(1 2 3 4 5) (defun gnum (s e / i l) (and (numberp s)(numberp e)(setq i s)(while (<= i e)(setq l (cons i l) i (1+ i)))) (reverse l)) ;;; i = startnumber n = number of numbers , d = difference (gnl- 100 6 12) -> (100 88 76 64 52 40) (defun gnl- (i n d / l) (setq l (list i))(repeat (1- n)(setq l (cons (setq i (- i d)) l)))(reverse l)) ;;; found this old lisp (grtxt.lsp) , don't know author but all credits are for this human from earth ;;; text string / coordinate point / color / angle justificationz ;;; *** UPPER CASE ONLY *** (grtxt (STRCASE "Rob") (getvar "viewctr") 1 0 "M") (defun grtxt (ts cp cl a j / vp ltb i xp z c p1 p2 lp ld n al) ;;; vertex points (setq vp '(( 1 ( 0.50 0.25))( 2 ( 0.50 0.55))( 3 ( 0.50 0.85))( 4 ( 0.50 1.00))( 5 ( 0.25 1.00)) ( 6 ( 0.00 1.00))( 7 (-0.25 1.00))( 8 (-0.50 1.00))( 9 (-0.50 0.85))(10 (-0.50 0.55)) (11 (-0.50 0.25))(12 (-0.50 0.10))(13 (-0.25 0.10))(14 ( 0.00 0.10))(15 ( 0.25 0.10)) (16 ( 0.50 0.10))(17 ( 0.50 -0.05))(18 ( 0.50 -0.45))(19 ( 0.50 -0.85))(20 ( 0.50 -1.00)) (21 ( 0.25 -1.00))(22 ( 0.00 -1.00))(23 (-0.25 -1.00))(24 (-0.50 -1.00))(25 (-0.50 -0.85)) (26 (-0.50 -0.40))(27 (-0.50 -0.05))(30 ( 0.35 0.85))(31 (-0.35 0.85))(32 (-0.35 -0.85)) (33 ( 0.35 -0.85))(40 ( 0.25 0.35))(41 (-0.25 0.35))(42 ( 0.25 -0.15))(43 (-0.25 -0.15)) (44 ( 0.00 0.45))(45 ( 0.00 -0.25))(50 ( 0.30 0.20))(51 ( 0.30 0.35))(52 ( 0.20 0.35)) (53 ( 0.20 0.20))(54 ( 0.30 0.10))(55 ( 0.30 -0.10))(56 ( 0.20 -0.10))(57 ( 0.20 0.10)) (60 (-0.30 0.20))(61 (-0.30 0.35))(62 (-0.20 0.35))(63 (-0.20 0.20))(64 (-0.30 0.10)) (65 (-0.30 -0.10))(66 (-0.20 -0.10))(67 (-0.20 0.10)))) ;;; letter table (setq ltb '(("A" 24 9 7 5 3 20 16 12) ("B" 12 15 1 3 5 8 24 21 19 17 15) ("C" 3 5 7 9 25 23 21 19) ("D" 3 5 8 24 21 19 3) ("E" 4 8 12 15 12 24 20) ("F" 4 8 12 15 12 24) ("G" 3 5 7 9 25 23 21 19 16 14) ("H" 20 -4 8 -24 16 12) ("I" 7 5 6 22 23 21) ("J" 4 19 21 23 25) ("K" 8 24 12 13 4 13 20) ("L" 8 24 20) ("M" 24 8 14 4 20) ("N" 24 8 20 4) ("O" 3 5 7 9 25 23 21 19 3) ("P" 12 15 1 3 5 8 24) ("Q" 3 5 7 9 25 23 21 19 3 -19 20 45) ("R" 20 14 12 15 1 3 5 8 24) ("S" 3 5 7 9 11 13 15 17 19 21 23 25) ("T" 4 8 6 22) ("U" 8 25 23 21 19 4 20) ("V" 8 22 4) ("W" 8 23 14 21 4) ("X" 4 -24 8 20) ("Y" 8 14 22 14 4) ("Z" 8 4 24 20) ("0" 3 5 7 9 25 23 21 19 -3 4 24) ("1" 31 7 6 22 21 23) ("2" 9 7 5 3 1 15 13 27 24 20) ("3" 9 7 5 3 1 15 13 15 17 19 21 23 25) ("4" 8 12 16 15 5 21) ("5" 4 8 12 15 17 19 21 23 25) ("6" 3 5 7 9 25 23 21 19 17 15 12) ("7" 8 4 22) ("8" 3 5 7 9 11 13 27 25 23 21 19 17 15 13 15 1 3) ("9" 25 23 21 19 3 5 7 9 11 13 16) ("<" 4 12 20) (">" 8 16 24) ("," 33 21) ("." 19 20 21 33 19) ("\'" 4 30) ("\"" 4 -30 7 31) (";" 50 51 52 53 -50 54 55 56 57 55 45) (":" 50 51 52 53 -50 54 55 56 57 55) ("\\" 8 20) ("/" 4 24) ("?" 11 10 7 5 2 1 45 22) ("|" 6 -44 45 22) ("+" 44 -45 13 15) ("=" 40 -41 43 42) ("-" 13 15) ("_" 20 24) (")" 6 2 18 22) ("(" 6 10 26 22) ("*" 40 -43 41 -42 45 44) ("&" 21 31 7 6 26 25 23 16) ("^" 10 6 2) ("%" 57 54 55 56 -57 63 60 61 62 -63 5 24) ("$" 3 5 7 9 11 13 15 17 19 21 23 25 -26 22 6) ("#" 24 -6 22 -4 1 -11 17 27) ("@" 42 15 40 44 41 13 43 45 42 17 3 5 7 9 25 23 21 19) ("!" 6 -45 22 22) ("~" 9 31 44 40 2) ("`" 8 31) ("[" 6 8 24 22) ("]" 6 4 20 22) ("{" 6 7 41 12 43 23 22) ("}" 6 5 40 16 42 21 22) (""))) ;;; text height (setq z (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")) 0.2)) (cond ;;; left justification ((eq (strcase (substr j 1 1)) "L") (setq xp (list (+ (car cp) z) (cadr cp)) i 1)) ;;; middle justification ((eq (strcase (substr j 1 1)) "M") (setq xp (list (- (car cp) (* z (strlen ts) 0.5)) (cadr cp)) i 1)) ;;; right justification ((eq (strcase (substr j 1 1)) "R") (setq xp (list (- (car cp) (* z (strlen ts) 1.5)) (cadr cp)) i 1)) ) (repeat (strlen ts) ;;; each charachter / line point list / letter point def (setq c (substr ts i 1) lp '() ld (cdr (assoc c ltb))) (while (> (length ld) 1) (setq p1 (cadr (assoc (abs (nth 0 ld)) vp)) p2 (cadr (assoc (abs (nth 1 ld)) vp)) p1 (mapcar '* (list z z) p1) p2 (mapcar '* (list z z) p2) p1 (mapcar '+ xp p1) p2 (mapcar '+ xp p2) lp (append lp (list (if (minusp (nth 0 ld)) 0 cl) p1 p2)) ld (cdr ld)) ) ;;; add rotation angle (setq n 0 al nil) (repeat (/ (length lp) 3) (setq al (cons (nth n lp) al) al (cons (polar cp (+ a (angle cp (nth (+ n 1) lp))) (distance cp (nth (+ n 1) lp))) al) al (cons (polar cp (+ a (angle cp (nth (+ n 2) lp))) (distance cp (nth (+ n 2) lp))) al)) (setq n (+ n 3)) ) (and al (grvecs (reverse al))) (setq xp (list (+ (car xp) (* z 1.5)) (cadr xp)) i (1+ i)) ) (prin1) ) ;;; probably won't need tracking mode (cut-copy-paste you know...) (defun RlxGrMenu_Get_Cell_ID (xl yl / inp dev tpt prev-tpt mark-current-tracking-point cell-id prev-cell-id prev-view-size cur-view-size rtn) (princ "\rEsc/Q/Rmouse to cancel, zoom with E(extend), Z(oom) or + / -") (setq prev-view-size (getvar "viewsize")) (while gr-loop (setq cur-view-size (getvar "viewsize")) (setq inp (vl-catch-all-apply 'grread (list T 8 1))) (if (vl-catch-all-error-p inp) (progn (setq gr-loop nil inp nil)(redraw)) (progn (setq dev (car inp) tpt (cadr inp)) (cond ;;; space , q or Q (Quit) ((and (= dev 2) (member (last inp) '(32 113 81))) (redraw)(setq gr-loop nil) ) ;;; point selection (3 (221.882 173.853 0.0)) ((= dev 3) (if (setq rtn (find_cell tpt xl yl)) (progn ;(alert (setq app (nth (1- (atoi rtn)) app-list))) (princ (strcat "\nLaunching : " (setq app (nth (1- (atoi rtn)) app-list)))) (setq gr-loop nil) ) ) ) ;;; device tracking point (probably don't need tracking mode) ((= dev 5) ;;; if mouse moved (if (or (/= (car prev-tpt)(car tpt)) (/= (cadr prev-tpt)(cadr tpt))) (progn (setq prev-tpt tpt ))) (if (not (equal cur-view-size prev-view-size)) (progn (setq prev-view-size cur-view-size) (redraw_menu) ) ) ) ; user pressed E of e ((member inp '((2 69)(2 101))) (command "zoom" "e")) ; user clicked R-mouse button, pressed enter or space (done selecting) ((or (equal (car inp) 25)(member inp '((2 13)(2 32)))) (redraw)(setq gr-loop nil app "Quit")) ; user pressed + ((equal inp '(2 43)) (vl-cmdf "zoom" "2x")) ; user pressed - ((equal inp '(2 45)) (vl-cmdf "zoom" ".5x")) ; user pressed z or Z ((member inp '((2 122)(2 90))) (vl-cmdf "'zoom" "")) ) ) ) ) (princ) ) ;;; pt = point , xl = x-list , yl = y-list ;;; scribble : (< 1 2 3) , (> 3 2 1) , (cdr (vl-sort '(1 2 3 4 5) '>)) -> '(4 3 2 1) (defun find_cell ( pt xl yl / ptx pty y-lst l n hit) (setq n nil hit nil ptx (car pt) pty (cadr pt) y-list (vl-sort (append yl (list 0)) '>)) (if (< (car xl) ptx (cadr xl)) (mapcar '(lambda (y)(if (and (not hit) (> pty y)) (setq hit T n (vl-position y y-list)))) y-list)) (if n (itoa (1+ n))) ) ;;; program assumes no self starting routines and start command is "C:" + app name (defun RlxGrMenu_Start_App (app / fn) (cond ((setq fn (findfile (strcat app ".lsp"))) (redraw)(load fn)(eval (read (strcat "(C:" app ")")))) ((wcmatch (strcase app) "QUIT")(princ "\nBye bye")(redraw)) ((wcmatch (strcase app) "CONFIG")(princ "\nUnder construction")(redraw)) (t (redraw)(princ (strcat "\nUnable to load " (vl-princ-to-string app) " ...bye"))) ) (princ) ) ;;; future... ;;; RlxGrMenu - Rlx Jul/25 (defun RlxGrMenu_future ( / ;;; global variables scr-res cell-rows cell-cols cell-col cell-id app-list ;;; display parameters like viewctr/viewsize/screensize (count_calcula) vc vs ss dx dy x- x+ y- y+ ip vc-x vc-y txt-h ;;; registry variables RlxGrMenu-nof-cell-rows RlxGrMenu-nof-cell-cols RlxGrMenu-app-list ) ;;; mostly not used because for now I just just one column with 10 rows (setq scr-res (screen_res) rows 3 cols 3 cell-col 141 cell-id 1) (count_calcula) (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare")) (RlxGrMenu_Init) (RlxGrMenu_Doit) (RlxGrMenu_Exit) (princ) ) (defun RlxGrMenu_Init ()(princ "\nUnder construction - RlxGrMenu_Init ")) (defun RlxGrMenu_Doit ()(princ "\nUnder construction - RlxGrMenu_Doit ")) (defun RlxGrMenu_Exit ()(princ "\nUnder construction - RlxGrMenu_Exit ")) (defun c:RlxGrMenu ()(draw_menu)) (defun c:t1 ()(draw_menu)) (defun t1 ()(draw_menu))

I managed to get rid of the flickering but keeping snap enabled. Here is the new version: offset.lsp Instead of hiding the polyline before doing the osnap, I now keep the polyline hidden and render it with grvecs instead. Therefore no snapping to itself and no more flickering!

oh yeah , the good ol' days of AutoCad , think I started around version 2.22 , 1987/88 or something. In that time only pull down & screen menu's , no xrefs , no model / paper space yet, IBM screens and keyboards you could knock out T-Rex with. Downside is , part of you will always be stucked in the good old days. I probably know only a couple % there is to know about AutoCad , maybe even less. I still go back to the old *mnu files for my toolbars because I still don't like ribbons. I want my buttons simple and always on the same location. But I do like colored buttons so now & again I upgrade one of my apps , this one is almost 30 years old and I couldn't live without it

Incremental Numbering Suite Version 4.0 Released. The main feature of the new version is the introduction of a dedicated 'Content Builder' to facilitate the construction of an incrementing string from an arbitrary number of incrementing and/or static components. With this feature, the user now has the ability to independently control the increment amount and increment frequency for each component of the string, enabling multiple sections of the string to increment by different amounts and at different rates to one another. The new version also introduces the ability to load & save application configurations, streamlining the operation of the program for multiple numbering systems.

https://www.theswamp.org/index.php?topic=30650.msg378483#msg378483

Better armored version, proof against extravagant users ;******************* p o r d e s í a r g o ******************** ;************************ G L A V C V S ************************* ;************************** F E C I T *************************** (defun c:mueveSegmto (/ lstSg dist i se lado op pr pr1 pa pb p1 p2 p3 p4 sgC r aC aR asr dameSgmtos erroria errores error0) (defun erroria () (defun errores (mens) (setq *error* error0) (prin1) ) (setq error0 *error* *error* errores ) ) (defun asr (p1 p2 p3 / a b) (if (> (abs (- (setq a (angle p1 p2)) (setq b (angle p2 p3)))) PI) (if (< a b) (if (> (+ a PI PI) b) - +) (if (> (- a PI PI) b) - +) ) (if (> a b) - +) ) ) (defun dameSgmtos (x pk / f d p s a tam a1 a2 b1 b2 c1 c2 sa sp) (if (= (cdr (assoc 0 x)) "LWPOLYLINE") (progn (setq tam (* (* (getvar "PICKBOX") (/ (getvar "VIEWSIZE") (cadr (setq ss (getvar "SCREENSIZE"))) ) ) 2 ) x (if (= (rem (cdr (assoc 70 x)) 2) 1) (cons (assoc 10 (reverse x)) x) x) b2 (cdr (assoc 10 (cdr (member (cons 10 (setq b1 (cdr (assoc 10 x)))) x)))) c1 (cdr (assoc 10 (cdr (member (cons 10 (setq c2 (cdr (assoc 10 (reverse x))))) (reverse x))))) ) (while (and (setq a1 (cdr p) a2 f f (cdr (assoc (if pk 10 11) (setq x (cdr (member (setq p (assoc 10 x) ) x)))))) (not (setq i (inters f (cdr p) (polar pk (+ (setq a (angle f (cdr p))) 1.5708) tam) (polar pk (- a 1.5708) tam)) )) ) ) (setq sc (list (cdr p) f) f (cdr (assoc (if pk 10 11) (cdr (member (setq p (assoc 10 x)) x)))) sp (if f (list (cdr p) f) (list b1 b2)) sa (if a1 (list a1 a2) (list c1 c2)) ) (list sa sc sp) ) ) ) (erroria) (setq dist (getreal "\nDistance of traslation (ENTER to get the distance on screen): ")) (if (setq lstSg (dameSgmtos (entget (car (setq se (entsel "\nSelect any segment in LWPOLYLINE...")))) (setq pr (cadr se)))) (if (setq pr1 (getpoint (setq pr i) "\nSide to act...")) (if (setq op (asr (setq p2 (car (setq sgC (cadr lstSg)))) pr pr1)) (setq dist (if dist dist (distance pr1 (inters p2 (setq p3 (cadr sgC)) (polar pr1 (- (setq aR (angle p2 p3)) (/ pi 2)) 9999) (polar pr1 (+ aR (/ pi 2)) 9999) nil)) ) pa (polar p2 (setq a (op (angle p2 (setq p3 (cadr sgC))) (/ pi 2.0))) dist) pb (polar p3 a dist) px1 (inters pa pb (car (car lstSg)) p2 nil) px2 (inters pa pb p3 (cadr (last lstSg)) nil) r (entmod (subst (cons 10 px1) (cons 10 p2) (entget (car se)))) r (entmod (subst (cons 10 px2) (cons 10 p3) (entget (car se)))) ) ) ) (princ "\nSelected object is not LWPOLYLINE....Exiting...") ) (princ) )

@PGia I went out for my 40-50 km bike ride today and I've been thinking about this for a while. I tried OVERKILL-MR and I admit I wasn't able to figure out the right ranges to remove the excess without causing any damage to the rest of the drawing (perhaps someone can prove otherwise). For this reason, in my opinion, I think you should look for another solution. I assume your ultimate goal is to have a clean drawing on which to create a polygon topology. To do this, use '_mapclean' in C3D, activating the options in 'Cleanup Actions': - Delete duplicates - Erase short objects - Break crossing objects - Dissolve pseudonodes Repeat this 2 or 3 times. I don't think this will solve all the problems. But it will leave the drawing ready for you to try creating a polygon topology. The problematic polylines that remain in the drawing will appear with each attempt to create the topology. It's a laborious but safe process. I imagine you're confused because you suddenly have to do something you haven't done before. But I think you'll have no choice but to waste a little time learning.

This related post may be helpful in this regard.

A couple of loose ends to tie up the all-too-fast V.2 release: -Multiple renumbering is currently done based on the order of the objects in the database: this looks ugly if the dispersion is too random. -As PGia has suggested, perhaps I should leave a brief explanation of the code's functionality. So, let's get to it: I've added a couple of improvements to the code that makes up the new version of <<Something different>>, which I've attached below. What's New in Version 2.1 The philosophy of this command is to concentrate the greatest number of functions in the fewest user actions. In addition to the previous capabilities: - individual creation/renumbering of texts based on the cursor position - multiple renumbering of texts using a selection window, thanks to the momentary activation of the 'V' key... The following has been added: - readjustment of the renumbering criteria for multiple texts ('V' key option): from now on, renumbering will be done based on proximity to the first corner indicated on the screen of the selection window. That is, if the selection window is from Northwest to Southwest, the renumbering increment will be in order from least to greatest distance from the Northwest corner. - In addition, the definition of the real-time selection window is discontinuous to differentiate it from others. ;******* <<S o m e t h i n g d i f f e r e n t V.2.1>> ******* ;******************* p o r d e s í a r g o ******************** ;************************ G L A V C V S ************************* ;************************** F E C I T *************************** (defun c:txtIncrem (/ tam capa ind para a c cl txsel le l s dameTexto uconfig obtcad ent loc tipC nC ps add errores error0 v actTX ventanea pv n cj acdoc md listOrda pr lt f ) (defun errores (mens) (setq *error* error0) (while (>= (boole 1 (getvar "UNDOCTL") 8) 8) (vla-endundomark acdoc) ) (prin1) ) (defun dameTexto (cad / v r l daleVuelta) ;;; WRITE HERE THE CODE YOU NEED TO CUSTOMIZE THE TEXT YOU WANT TO ENTER OR CREATE (defun daleVuelta (a) (cond ((and (> a 64) (< a 91)) (if (> (setq a (+ a 1)) 90) (setq a -65) a)) ((and (> a 96) (< a 123)) (if (> (setq a (+ a 1)) 122) (setq a -97) a)) ((and (> a 47) (< a 58)) (if (> (setq a (+ a 1)) 57) (setq a -48) a)) ) ) (foreach v (reverse (vl-string->list cad)) (if (or (not r) (minusp r)) (setq l (cons (abs (setq r (daleVuelta v))) l)) (setq l (cons v l)) ) ) (vl-list->string (if (minusp r) (cons (if (= r -48) 49 (car l)) l) l)) ) (defun ventanea (/ p no se) (if (listp (setq p (cadr l))) (progn (redraw) (grvecs (list -7 pv (setq no (list (car pv) (cadr p))))) (grvecs (list -7 pv (setq se (list (car p) (cadr pv))))) (grvecs (list -7 no p)) (grvecs (list -7 se p)) ) ) ) (defun actTX (e / le) (entmod (subst (cons 1 tx) (assoc 1 (setq le (entget e))) le)) (setq tx (dameTexto tx)) nil ) (defun listOrda (cj pr / e n l) (vl-sort (while (setq e (ssname cj (setq n (if n (1+ n) 0)))) (setq l (cons (list (cdr (assoc 10 (entget e))) e) l)) ) '(lambda (a b) (< (distance pr (car a)) (distance pr (car b))) ) ) ) (setq error0 *error* *error* errores ) (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) (while (>= (boole 1 (getvar "UNDOCTL") 8) 8) (vla-endundomark acdoc) ) (princ (setq s "Select PREVIOUS number text or type it... ")) (while (not para) (setq l (grread T 13 2)) (if (not (listp (cadr l))) (if (member (car l) '(2 3 11 25)) (cond ((or (= (cadr l) 13) (= (car l) 25) (= (car l) 11)) (if (and c (not (wcmatch c "*.*"))) (setq ind c para T) (if (not c) (setq para T)) ) ) ((> (cadr l) 31) (setq c (if c (strcat c (chr (cadr l))) (chr (cadr l)))) (prompt (strcat "\r" s c)) ) ((= (cadr l) 8) (if (setq c (if c (substr c 1 (- (strlen c) 1)))) (prompt (strcat "\r" s c)) ) ) (T (princ) ) ) ) (if (= (car l) 3) (if (and (setq e (nentselp (cadr l))) (= (cdr (assoc 0 (setq le (entget (setq e (car e)))))) "TEXT")) (if (not (wcmatch (setq ind (cdr (assoc 1 le))) "*.*")) (setq capa (cdr (assoc 8 le)) a (cdr (assoc 40 le)) cl (cdr (assoc 62 le)) para T) (princ "\n*** The selected object is not valid. Please, try again... ***") ) ) ) ) ) (setq para nil) (if (not capa) (while (not para) (if (and (setq e (car (entsel "\nLAYER/HEIGHT: Select a sample text object (ENTER or RIGHT CLICK to type it)... "))) (setq l (entget e)) ) (if (= (cdr (assoc 0 l)) "TEXT") (setq capa (cdr (assoc 8 l)) a (cdr (assoc 40 l)) para T) (princ "\n*** The selected object is not a TEXT. Please, try again... ***") ) (if (not capa) (if (setq capa (getstring "\nType Layer name: ")) (if (tblsearch "layer" capa) (if (not (setq a (getreal "\nType Height: "))) (setq capa (princ "\n*** A valid height has not been specified. Please, type it again... ***") capa nil) (setq para T) ) (setq capa (princ "\n*** Specified layer does not exist. Please, type it again... ***") capa nil) ) ) ) ) ) ) (setq tx (dameTexto ind) s nil) (while ;(and (setq l (grread T (if s 4 13) (if s 2 0))) (member (car l) '(5 3 2))) (and (setq l (grread T (cond (s 4) (v 4) (T 13)) (cond (s 2) ((and pv v) 1) (v 2) (T 0)))) (member (car l) '(5 3 2))) (prompt (strcat "\rSelect text to modify or insert new text \"" tx "\" (<V> for ON/OFF multiple selection or <RIGHT CLICK> for exit)")) (setq tam (* (getvar "pickbox") (/ (GETVAR "VIEWSIZE") (CADR (GETVAR "SCREENSIZE")))) para nil n nil) (if (= (car l) 2) (cond ((member (cadr l) '(86 118)) (setq v (not v)) ) ;;; HERE MORE CASES ?...(ascii "V") ) (if (or v (setq s (ssget "_C" (list (- (car (setq p (cadr l))) tam) (- (cadr p) tam)) (list (+ (car p) tam) (+ (cadr p) tam)) (list (cons 0 "TEXT")) ) ) ) (cond ((= (car l) 3) (if s (setq md (vla-startundomark acdoc) s (actTX (ssname s 0))) (if pv (if (setq cj (ssget "_C" pv (cadr l) (list (cons 0 "TEXT"))) lt (if cj (listOrda cj pv)) pv (if cj (vla-startundomark acdoc)) v (redraw) lt lt) ;;; (while (setq e (ssname cj (setq n (if n (1+ n) 0)))) (foreach f lt (actTX (cadr f)) ) ) (setq pv (cadr l)) ) ) ) ((and pv (= (car l) 5) (not s)) (ventanea) ) (T (princ) ) ;;; HERE MORE CASES ?... ) (cond ((= (car l) 3) (entmake (list '(0 . "TEXT") (cons 8 capa) (cons 62 (if cl cl 256)) (cons 40 a) (cons 1 tx) (cons 10 (list (car p) (cadr p) 0.0)) ) ) (setq tx (dameTexto tx)) ) (T (if (/= (car l) 5) (princ) ) ) ;;; HERE MORE CASES ?... ) ) ) ) (while (>= (boole 1 (getvar "UNDOCTL") 8) 8) (vla-endundomark acdoc) ) (princ) )

Here's my take on it: (defun c:foo (/ lm:unformat b el p r s sp tx) (cond ((setq s (ssget ":L" '((0 . "CIRCLE")))) (cond ((null (tblobjname "block" "Bubble")) (entmake '((0 . "BLOCK") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockReference") (66 . 1) (2 . "Bubble") (10 0. 0. 0.) (70 . 2) ) ) (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbCircle") (10 0. 0. 0.) (40 . 1.) ) ) (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbText") (10 0. 0. 0.) (40 . 0.75) (1 . "") (50 . 0) (41 . 1) (51 . 0) (7 . "Standard") (71 . 0) (72 . 1) (11 0. 0. 0.) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "") (2 . "#") (70 . 8) (73 . 0) (74 . 2) (280 . 1) ) ) (entmake '((0 . "ENDBLK") (100 . "AcDbBlockEnd") (8 . "0"))) ) (command "_.ATTSYNC" "_NAME" "BUBBLE") ) ;;-------------------=={ UnFormat String }==------------------;; ;; ;; ;; Returns a string with all MText formatting codes removed. ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; str - String to Process ;; ;; mtx - MText Flag (T if string is for use in MText) ;; ;;------------------------------------------------------------;; ;; Returns: String with formatting codes removed ;; ;;------------------------------------------------------------;; (defun lm:unformat (str mtx / _replace rx) (defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new) ) (if (setq rx (vlax-get-or-create-object "VBScript.RegExp")) (progn (setq str (vl-catch-all-apply (function (lambda () (vlax-put-property rx 'global actrue) (vlax-put-property rx 'multiline actrue) (vlax-put-property rx 'ignorecase acfalse) (foreach pair '(("\032" . "\\\\\\\\") (" " . "\\\\P|\\n|\\t") ("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]" ) ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);") ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}") ("$1" . "[\\\\]({)|{") ) (setq str (_replace (car pair) (cdr pair) str)) ) (if mtx (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str) ) (_replace "\\" "\032" str) ) ) ) ) ) (vlax-release-object rx) (if (null (vl-catch-all-error-p str)) str ) ) ) ) (setq sp (vlax-ename->vla-object (cdr (assoc 330 (entget (ssname s 0)))))) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (setq r (/ (cdr (assoc 40 (setq el (entget e)))) 2.)) (setq p (cdr (assoc 10 el))) (cond ((setq tx (ssget "_C" (mapcar '- p (list r r r)) (mapcar '+ p (list r r r)) '((0 . "*TEXT"))) ) (setq r (* 2 r)) (setq b (vla-insertblock sp (vlax-3d-point p) "Bubble" r r r 0.)) (vla-put-textstring (car (vlax-invoke b 'getattributes)) (lm:unformat (cdr (assoc 1 (entget (ssname tx 0)))) nil) ) (entmod (append (entget (vlax-vla-object->ename b)) '((8 . "BUBBLE")))) (entdel e) (entdel (ssname tx 0)) ) ) ) ) ) (princ) )

@PGia Thanks for the encouragement and checking the results. I measure from the vertices instead of the lines. Those are calculated and the lines are just to connect the points. So perpendicular to the middle of segments of the centerline will always be a bit off, but if you measure from the vertices it should be centered correctly. Just like @GP_ said. I kept going in the same direction and I have made some improvements and got rid of some bugginess: The centerline should be a little more accurate now because of extra measurements (blue line) Crossing polylines get sharp corners on negative side Corner checks are done on all intersections of temporary line now (red line) More error checking so it doesn't crash on some of the example lines I left all of the 'animation' code commented out so you can give it a try ;| ; Calculate centerline between two polylines - dexus ; Function checks intersections of the offsets of two lines to create a middle/avarage line. ; https://www.cadtutor.net/forum/topic/98778-hybrid-parallel/page/6/#findComment-677246 ; Version 0.1 - Initial release 19-11-2025 ; Version 0.2 - Added corner support on negative side of crossing polylines 27-11-2025 ; Version 0.3 - Extra check using distance between vertex and closest point 28-11-2025 ; Version 0.4 - Added error handler 28-11-2025 |; (defun c:cl (/ corners ent1 ent2 loop maxlen offset offsetdistance pts s1 s2 ss start te0 te1 te2 LM:ProjectPointToLine LM:intersections _addPoints _avarageAngle _cornerOffset _doOffset _getAnglesAtParam _getLength _polyline _side _wait *error*) (defun *error* (st) (if (wcmatch (strcase st t) "*break,*cancel*,*exit*") (redraw) (progn (vl-bt) (princ (strcat "\nOops! Something went wrong: ") st) ) ) (if (not (vlax-erased-p te0)) (entdel te0)) (if (and te1 (not (vl-catch-all-error-p te1))) (mapcar 'vla-delete te1)) (if (and te2 (not (vl-catch-all-error-p te2))) (mapcar 'vla-delete te2)) (princ) ) ;| ; Draw Polyline - dexus ; Draw a polyline from a list of points, but filter out colinear points ; @Param lst list of points ; @Returns ename of polyline |; (defun _polyline (lst closed / prev pts) (while lst (cond ( (and (cdr lst) prev (or (equal (cdr lst) prev 1e-8) ; Remove duplicate points (null (inters prev (car lst) prev (cadr lst))) ; Remove collineair points ) ) ) ((setq pts (cons (cons 10 (setq prev (car lst))) pts))) ) (setq lst (cdr lst)) ) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length pts)) (cons 8 (getvar 'clayer)) (cons 70 (if closed 1 0)) ) (reverse pts) ) ) ) (defun _side (pline pnt / cpt end target der) ; https://www.theswamp.org/index.php?topic=55685.msg610429#msg610429 (setq cpt (vlax-curve-getClosestPointTo pline pnt) end (vlax-curve-getEndParam pline) target (vlax-curve-getParamAtPoint pline cpt) der (if (and (equal target (fix target) 1e-8) (or (vlax-curve-isClosed pline) (and (not (equal (vlax-curve-getStartParam pline) target 1e-8)) (not (equal end target 1e-8))) ) ) (mapcar '- (polar cpt (angle '(0 0) (vlax-curve-getFirstDeriv pline (rem (+ target 1e-3) end))) 1.0) (polar cpt (angle (vlax-curve-getFirstDeriv pline (rem (+ (- target 1e-3) end) end)) '(0 0)) 1.0) ) (vlax-curve-getFirstDeriv pline target) ) ) (minusp (sin (- (angle cpt pnt) (angle '(0.0 0.0) der)))) ) ;; Intersections - Lee Mac ;; mod - [int] acextendoption enum of intersectwith method (defun LM:intersections ( ob1 ob2 mod / lst rtn ) (if (and (vlax-method-applicable-p ob1 'intersectwith) (vlax-method-applicable-p ob2 'intersectwith) (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)) ) (repeat (/ (length lst) 3) (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn) lst (cdddr lst)) ) ) (reverse rtn) ) (defun _getLength (ent) (- (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (vlax-curve-getDistAtParam ent (vlax-curve-getStartParam ent)) ) ) (defun _wait (msec) (not ( (lambda (start) (while (< (- (getvar 'millisecs) start) msec)) ) (getvar 'millisecs) ) ) ) (defun _addPoints (lst ent pts / len) (setq len (_getLength ent)) (setq lst (mapcar (function (lambda (pt) (list (/ (vlax-curve-getDistAtPoint ent pt) len) pt))) lst)) (setq pts (append lst pts)) ; Animation ; (setq pts (vl-sort pts (function (lambda (a b) (< (car a) (car b)))))) ; (redraw) ; ( ; (lambda (lst) ; (while (cadr lst) ; (grdraw (cadar lst) (cadadr lst) 3) ; (setq lst (cdr lst)) ; ) ; ) ; pts ; ) ; (vla-update ent) ; (_wait 40) ; End animation pts ) (defun _doOffset (offset / lst rtn) ; Global vars: pts ent1 ent2 s1 s2 te1 te2 (setq te1 nil) (setq te2 nil) (setq rtn (cond ((equal offset 0.0 1e-8) (if (setq lst (LM:intersections ent1 ent2 acExtendNone)) (setq pts (_addPoints lst ent1 pts)) ) lst ) ( (or ; Make offset (vl-catch-all-error-p (setq te1 (vl-catch-all-apply 'vlax-invoke (list ent1 'Offset (if s1 offset (- offset)))))) (vl-catch-all-error-p (setq te2 (vl-catch-all-apply 'vlax-invoke (list ent2 'Offset (if s2 offset (- offset)))))) ) (princ "\nOffset failed. ") nil ) ((setq lst (LM:intersections (car te1) (car te2) acExtendNone)) (setq pts (_addPoints lst (car te1) pts)) lst ) ) ) (if (and te1 (not (vl-catch-all-error-p te1))) (mapcar 'vla-delete te1)) (if (and te2 (not (vl-catch-all-error-p te2))) (mapcar 'vla-delete te2)) rtn ) ;| ; Project Point onto Line - Lee Mac ; @Param pt point to project ; @Param p1 first point of line ; @Param p2 second point of line ; @Returns projected point |; (defun LM:ProjectPointToLine ( pt p1 p2 / nm ) (setq nm (mapcar '- p2 p1) p1 (trans p1 0 nm) pt (trans pt 0 nm)) (trans (list (car p1) (cadr p1) (caddr pt)) nm 0) ) (defun _getAnglesAtParam (ent pa / ang1 ang2) (if (and (vlax-curve-isClosed ent) (= pa 0)) ; Special case for closed Polyline (setq ang1 (vlax-curve-getFirstDeriv ent 1e-14) ang2 (vlax-curve-getFirstDeriv ent (- (fix (vlax-curve-getEndParam ent)) 1e-14))) (setq ang1 (vlax-curve-getFirstDeriv ent (+ pa 1e-14)) ang2 (vlax-curve-getFirstDeriv ent (- pa 1e-14))) ) (if (and ang1 ang2) (list (angle '(0 0 0) ang1) (angle '(0 0 0) ang2) ) ) ) ;| ; Avarage Angle - dexus ; Get angle of a line between two angles ; @Param ang1 real - Angle in radians ; @Param ang2 real - Angle in radians ; @Returns real - Angle in radians |; (defun _avarageAngle (ang1 ang2) (if (< (rem (+ ang1 pi) (+ pi pi)) (rem (+ ang2 pi) (+ pi pi)) ) (+ (* (- ang2 ang1) 0.5) ang1) (+ (* (- ang1 ang2) 0.5) ang2) ) ) ;| ; Calculate exact offset distance on a corner - dexus ; pt1 - Point on corner ; pt2 - Point on other side ; pt3 - Center for bisector ; pt4 - Target for corner of the offset ; pt5 - Find perpendicular point for offset distance ; / ; / ; -------- pt1 pt5 ; \ / ; pt4 ; \ ; ---- pt3 ----- pt2 ----- ; ; @Param ent1 Line to check corners ; @Param ent2 Opposing line ; @Returns List of offset distances (pt1 -> pt5) to calculate |; (defun _cornerOffset (ent1 ent2 / ang1 ang2 ang3 index pt1 pt2 pt3 pt4 pt5 rtn) (setq index 0) (repeat (fix (vlax-curve-getEndParam ent1)) (and (setq pt1 (vlax-curve-getPointAtParam ent1 index)) ; Point on corner (setq ang1 (_getAnglesAtParam ent1 index)) ; Angles of pt1 (setq ang1a (_avarageAngle (car ang1) (cadr ang1))) (setq te0 (entmakex (list (cons 0 "line") (cons 10 pt1) (cons 11 (polar pt1 (- ang1a halfPi) 1))))) ; Temp line for finding the angle on the other side (foreach pt2 (LM:intersections (vlax-ename->vla-object te0) ent2 acExtendThisEntity) ; Point on other side (and (setq ang2 (_getAnglesAtParam ent2 (vlax-curve-getParamAtPoint ent2 pt2))) ; Angle of pt2 (if (equal (rem (car ang1) pi) (rem (car ang2) pi) 1e-8) ; Is parallel? (and (setq pt3 (mapcar (function (lambda (a b) (* (+ a b) 0.5))) pt1 pt2)) ; Midpoint (setq ang3 (car ang1)) ; Same angle als ang1 ) (and (setq pt3 (inters pt1 (polar pt1 (car ang1) 1) pt2 (polar pt2 (car ang2) 1) nil)) ; Find center for bisector (setq ang3 (_avarageAngle (angle pt1 pt3) (angle pt2 pt3))) ; Angle of bisector ) ) (setq pt4 (inters pt3 (polar pt3 ang3 1) pt1 (polar pt1 (+ ang1a halfPi) 1) nil)) ; Find target for corner of the offset (setq pt5 (LM:ProjectPointToLine pt4 pt1 (polar pt1 (+ (car ang1) halfPi) maxlen))) ; Find perpendicular point for offset distance (setq rtn (cons (distance pt1 pt5) rtn)) ; Return offset distance ; Animation ; (progn ; (redraw) ; (grdraw pt1 pt2 1) ; (grdraw pt4 pt5 2) ; (grdraw pt1 pt5 2) ; (vla-update ent1) ; (_wait 120) ; ) ; End Animation ) ) ) (if (not (vlax-erased-p te0)) (entdel te0)) (setq index (1+ index)) ) rtn ) (if (and (not (while (cond ((not (setq ss (ssget '((0 . "LWPOLYLINE"))))) (princ "\nNothing selected. Try again...\n") ) ((/= (sslength ss) 2) (princ "\nSelect 2 polylines! Try again...\n") ) ((and (setq ent1 (ssname ss 0)) (setq ent2 (ssname ss 1)) (setq ent1 (vlax-ename->vla-object ent1)) (setq ent2 (vlax-ename->vla-object ent2)) ) nil ; Stop loop ) ) ) ) ent1 ent2 ) (progn (setq s1 (_side ent1 (if (< ; Check closest point for edgecase with crossing lines in oposite directions (distance (vlax-curve-getStartPoint ent1) (vlax-curve-getEndPoint ent2)) (distance (vlax-curve-getEndPoint ent1) (vlax-curve-getEndPoint ent2)) ) (vlax-curve-getEndPoint ent2) (vlax-curve-getStartPoint ent2) ) ) ) (setq s2 (_side ent2 (vlax-curve-getStartPoint ent1) ) ) (if (not (numberp halfPi)) (setq halfPi (* pi 0.5))) (setq maxlen (* 1.1 (max (_getLength ent1) (_getLength ent2) ( (lambda (ent1 ent2 / step de1 div p_step dis dmax) (setq step (/ (setq de1 (vlax-curve-getDistAtParam ent1 (vlax-curve-getEndParam ent1))) 500) div step dmax 0.00) (while (< div de1) (setq p_step (vlax-curve-getPointAtDist ent1 div) dis (distance p_step (vlax-curve-getClosestPointTo ent2 p_step))) (if (> dis dmax) (setq dmax dis)) (setq div (+ div step)) ) dmax ) ent1 ent2 ) ) ) ) (mapcar ; Add half distances from closest point to every vertex (function (lambda (ent1 ent2 / index pt) (setq index 0) (repeat (fix (vlax-curve-getEndParam ent1)) (setq pt (vlax-curve-getPointAtParam ent1 index) corners (cons (* (distance pt (vlax-curve-getClosestPointTo ent2 pt)) 0.5) corners) index (1+ index)) ; Animation ; (redraw) ; (grdraw pt (vlax-curve-getClosestPointTo ent2 pt) 4) ; ( ; (lambda (mid) (grdraw mid (polar mid (+ (angle pt (vlax-curve-getClosestPointTo ent2 pt)) halfPi) (car corners)) 2)) ; (mapcar (function (lambda (a b) (* (+ a b) 0.5))) pt (vlax-curve-getClosestPointTo ent2 pt)) ; ) ; (vla-update ent1) ; (_wait 120) ; End animation ) )) (list ent1 ent2) (list ent2 ent1) ) (setq corners (vl-sort (append corners (_cornerOffset ent1 ent2) (_cornerOffset ent2 ent1)) '<) offsetdistance (/ maxlen 1024.0)) (if (LM:intersections ent1 ent2 acExtendNone) ; For crossing polylines, add negative values (setq offset (- maxlen) corners (append (mapcar '- (reverse corners)) corners)) (setq offset 0.0) ) (while (progn (while (and corners (> offset (car corners))) ; Calculated offset values to check (_doOffset (car corners)) (setq corners (cdr corners)) ) (setq loop ; Incremental check (cond ((> offset maxlen) nil) ((_doOffset offset) (setq start t)) ((not start) t) (start nil) ) ) (setq offset (+ offset offsetdistance)) loop ) ) (if pts ; Draw polyline (_polyline (mapcar 'cadr (vl-sort pts (function (lambda (a b) (< (car a) (car b)))))) (and (vlax-curve-isClosed ent1) (vlax-curve-isClosed ent2)) ) ) ) ) (redraw) (princ) ) And here is an animation of it working just because they are fun to look at :

Load VT , start with VT (or C:VT) Click on one of the attdef's , you get the main dialog Click on setup (bottom right) and change difference to 5 , click on ok to return to main dialog Finaly click on Renum and select all attdefs , enter, done... VT uses grread in a constant loop so exit with escape, cancel or spacebar that will get you in quick menu and you can escape / Quit / cancel from there. Not all buttons will work because some are company specific like revision but for now it should get you what you need. VT.LSP

@Steven P did trusted paths above including check if running Bricscad which does not have trusted paths. Another way to push lisps to a pc is you can via lisp unzip a ZIP file to a location, advantage is only one file rather than copying a whole directory. I use this as part of install lisps. Its super fast. Just need a "Filename" (startapp (strcat "powershell -command Expand-Archive -Path '" filename "' -DestinationPath 'C:/xxx-CAD-TOOLS' -FORCE")) (alert "programs unzipped to C:/xxx-CAD-TOOLS")

This reminds me on SCREENMENU (picture 1), but you're solution are better . One old programmer with a lot experience in programming, in AutoCAD, told me about SCREENMENU when I tried to do something. And I forget to mention, I have never done anything with SCREENMENU .

That looks good. Years ago I had FastCAD which had a menu very similar for inserting blocks. My current LISP to try to do similar used DCL and buttons, however a couple of tweaks this could (pretty much) copy what was in FastCAD (it was about the best bit of FastCAD). Example call say 'Doors', your pop-up menu appears and instead of text an image of the block to insert (can make a simplified block using vector graphics, same way as your text). I'll add another line to my to-do list. EDIT. A comment I was going to make last night. You reminded me. The vector letters are handy to keep somewhere - in a DCL for example you can create an image (or image button), using vector letters but add colours to highlight text:

Here is a version that only uses lisp. You will have to download grsnap: https://www.lee-mac.com/grsnap.html It does flicker when I am preventing it from snapping to itself, rest seems to work fine. Keyboard input works a s well. Give it a try: offset.lsp

have done a sort of messenger in the past with (m)text so just wanted to try something else. With vectors a simple redraw and your plate is clean again. I was / am considering adding background but for now wanted to keep it fast & furious due to workload (turning my boss's promises into reality)

Hi I’m attaching the code. But first, a brief explanation of how it works. The function is implemented by calling MiGRTexto with one parameter: the desired height for the real-time texts (this should be a value between 0.5 and 1) Therefore, it can be placed inside a main function that can be called from the command line (e.g., (defun c:myCommand)). As for the code that provides functionality, it's actually very simple: it consists of a text next to the right CROSSHAIR and an MTEXT below it. These must be properly managed so that they dynamically update their size, location and content—it's that straightforward. From there, it’s just a matter of adding code to achieve whatever final functionality the user needs. In the attached code, a small emulator for the "pline" command is implemented, triggered by a LEFT CLICK event. This event calls funcionPrincipal, which is provided with two arguments: the screen point indicated and the entity name (or nil) of the object under the PICKBOX at that location. These two arguments should be enough to enable any subsequent operation. It’s important to note that the entire behavior relies on GRREAD, and therefore on mouse and keyboard events. These events are handled using several clauses within a cond expression, which can be extended or modified by the user. I haven’t implemented any code to add object snap functionality. Doing so would considerably complicate the code, and for some users, it may not be necessary. In any case, suggestions and improvements (regarding snapping or any other proposals) are welcome in this thread—for those (myself included) who may want to improve or add new features. I won’t go on any further. Now, the code... ;******************* p o r d e s í a r g o ******************** ;************************ G L A V C V S ************************* ;************************** F E C I T *************************** (defun MiGRTexto (factor / l se e le txTmp txTmp1 txOk tam p pa pt pt1 i? v1 polil alt tx para erroria errores error0 textoGR1 textoGR2 funcionPrincipal) (defun erroria () (defun errores (mens) (setq *error* error0) (vla-delete txTmp) (vla-delete txTmp1) (redraw) (if e (redraw e 4)) (prin1) ) (setq error0 *error* *error* errores ) ) (defun funcionPrincipal (pt e) (setvar 'LASTPOINT pt) ;;;INICIO(START) EMULAD(T)OR "pline" (if polil (entmod (append (entget polil) (list (cons 10 pt)))) (if (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 "0") (cons 90 2) '(70 . 128) '(62 . 256) (cons 10 pa) (cons 10 pt) ) ) (setq polil (entlast)) ) ) (setq pa pt) ;;;FIN(END) EMULAD(T)OR "pline" ) (defun textoGR1 () ;THIS FUNCTION RETURN TEXT STRING TO DISPLAY ABOVE CURSOR. ADJUST IT TO SUIT YOUR NEEDS ;ESTA FUNCIÓN DEVUELVE EL TEXTO A MOSTRAR SOBRE EL CURSOR. MIDIFÍCALA SEGÚN LO NECESITES (rtos (distance (getvar 'LASTPOINT) p) 2 3) ) (defun textoGR2 (lp / lp MT) ;ESTA FUNCIÓN DA EL FORMATO NECESARIO AL MTEXT QUE SE MOSTRARÁ BAJO EL CURSOR (foreach l lp (if MT (setq MT (strcat MT (car l) " {\\fLucida Sans Unicode|b0|i0|c0|p34;\\C4;" (cadr l) "}")) (setq MT (strcat (car l) " {\\fLucida Sans Unicode|b0|i0|c0|p34;\\C4;" (cadr l) "}")) ) (setq MT (if (equal l (last lp)) MT (strcat MT "\\P"))) ) ) (defun dameGRT2 (le / cl to) ;THIS FUNCTION RETURN THE LIST OF PAIRS THAT textoGR2 NEEDS TO FORMAT CONTENTS OF MTEXT. ADJUST IT TO SUIT YOUR NEEDS ;ESTA FUNCIÓN DEVUELVE LA LISTA DE PARES QUE NECESITA textoGR2 PARA GENERAR LA CADENA DE TEXTO QUE NECESITA EL MTEXT (list (list "Object" (setq to (cdr (assoc 0 le)))) (list "Layer" (cdr (assoc 8 le))) (list "Color" (if (setq cl (cdr (assoc 62 le))) (itoa cl) "BYLAYER")) (list "XData?" (if (assoc -3 le) "YES" "NO")) ) ) (erroria) (setq txTmp (vla-AddText (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) "0" (VLAX-3D-POINT '(0 0)) 0.1) txTmp1 (vla-AddMText (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point '(0 0)) 5000 "0") i? T ) (vla-put-color txTmp 1) (vla-put-visible txTmp 0) (vla-put-color txTmp1 2) (vla-put-visible txTmp1 0) (while (and (not para) (setq l (grread nil 13 0))) (setq tam (* (getvar "PICKBOX") (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) 2 factor ) ) (if e (redraw e 4)) (setq e (if (setq se (if (listp (setq p (cadr l))) (nentselp p))) (if (and (not (member (vlax-ename->vla-object (car se)) (list txTmp txTmp1))) (member (cdr (assoc 0 (setq le (entget (car se) '("*"))))) '("LWPOLYLINE" "POLYLINE" "LINE" "SHAPE" "3DFACE" "INSERT" "TEXT" "MTEXT" "ATTRIB") ) ) (car se) ) ) ) (if (and i? e) (vla-put-visible txTmp1 1) (vla-put-visible txTmp1 0)) (prompt (strcat "\rLWPOLYLINE mode: " (if pa "next" "first") " point... (Press \'F10\' for " (if i? "DEACTIVATE" "ACTIVATE") " real-time reporting)")) (cond ((= (car l) 5) (if (not v1) (setq v1 (vla-put-visible txTmp 1) v1 T)) (setq pt (list (+ (car p) (* tam 0.8)) (+ (cadr p) (/ tam 2.2)))) (redraw) (if pa (grvecs (list 7 pa p))); THIS LINE IS PART OF THE "pline" EMULATOR CODE. DISABLE IT IF YOU DONT WANT TO USE THE EMULATOR IMPLEMENTED IN funcionPrincipal ; ESTA LINEA FORMA PARTE DEL EMULADOR "pline". DESACTIVALO SI ELIMINAS EL CÓDIGO EMULADOR IMPLEMENTADO EN funcionPrincipal (vlax-put-property txTmp 'InsertionPoint (vlax-make-variant (vlax-3d-point pt))) (vlax-put txTmp 'Height tam) (vlax-put txTmp 'TextString (textoGR1));<<<-- MODIFICAR ESTA LINEA DE CÓDIGO PARA QUE 'TextString MUESTRE EL TEXTO DESEADO (if (and i? e) (progn (redraw e 3) (setq pt1 (list (car pt) (- (cadr p) (/ tam 2.)))) (vlax-put-property txTmp1 'InsertionPoint (vlax-make-variant (vlax-3d-point pt1))) (vlax-put txTmp1 'Height tam) (vlax-put txTmp1 'TextString (textoGR2 (dameGRT2 le))) ) ) ) ((= (car l) 3) (if pa (funcionPrincipal p (car se)) (setq pa p))); ((= (car l) 25) (setq para T)); BOTON DERECHO = SALIR ((member (cadr l) '(67 99)) (if polil (setq para (entmod (subst (cons 70 1) (assoc 70 (entget polil)) (entget polil)))))); ((= (cadr l) 21) (setq i? (not i?))) ;;; AQUI DEBAJO EL CODIGO PARA GESTIONAR EL RESTO DE OPCIONES ;;; BELOW YOU CAN ADD MORE CLAUSES TO 'cond' TO EXTEND THE CODE FUNCTIONALITY (T ;REST OF CASES: WE DO NOTHING ) ;| .... .... |; ) ) (vla-delete txTmp) (vla-delete txTmp1) (redraw) (if e (redraw e 4)) (princ) )

This returns the serial number of the motherboard. It is more unique than the hard drive's serial number and also more unique than the variant of this same function that uses "Select * from Win32_BaseBoard". (defun obt_UUID (/ LObj SObj OSObj UUID) (setq LObj (vlax-create-object "WbemScripting.SWbemLocator") SObj (vlax-invoke LObj 'ConnectServer nil nil nil nil nil nil nil nil) OSObj (vlax-invoke SObj 'ExecQuery "SELECT UUID FROM Win32_ComputerSystemProduct") ) (vlax-for Obj OSObj (setq UUID (vlax-get Obj 'UUID)) ) (foreach Obj (list LObj SObj OSObj) (and Obj (vlax-release-object Obj)) ) UUID ) This might be a good option if you want your program to continue working when the user changes their hard drive but not their motherboard.

I guess using GRREAD to pick a point in real time and behind the scenes do a search box looking for text and in particular a match say "ABC" in "ABCDEFGH" if yes then zoom in on that text. I am not good at GRREAD code so some one else may be able to help. Search box.part based on a pick point. (setq off 18) ; needs to be changed to suit a dwg. (while (setq pt (getpoint "\nPick point ")) (setq pt1 (polar pt (* 0.25 pi) off)) (setq pt2 (polar pt (* 0.75 pi) off)) (setq pt3(polar pt (* 1.25 pi) off)) (setq pt4 (polar pt (* 1.75 pi) off)) (setq pts (list pt1 pt2 pt3 pt4 pt1)) (setq ss (ssget "CP" pts '((0 . "TEXT")))) (if (= ss nil) (princ "\n nothing found ") (princ (strcat "\n" (cdr (assoc 1 (entget (ssname ss 0)))) " found")) ) )

;| Adapted from an original idea by ElpanovEvgeniy 26.02.2010 https://www.theswamp.org/index.php?topic=30650.msg378483#msg378483 ******************* p o r d e s í a r g o ******************** ************************ G L A V C V S ************************* ************************** F E C I T *************************** |; (defun c:offSetea (/ se e pS c? c?c d dk r r1 pu p0 p1 p2 p3 o pt1 pt2 pt3 px1 px2 pa pb ct-r a42 op lgr bd fe *s* para asr dameCentroRadio erroria errores error0) (defun erroria () (defun errores (mens) (setq *error* error0) (entmod fe) (prin1) ) (setq error0 *error* *error* errores ) ) (defun asr (p1 p2 p3 / a b) (if (> (abs (- (setq a (angle p1 p2)) (setq b (angle p2 p3)))) PI) (if (< a b) (if (> (+ a PI PI) b) - +) (if (> (- a PI PI) b) - +) ) (if (> a b) - +) ) ) (defun dameCentroRadio (pt1 pt2 a42 / d radio h aP th centro) (setq radio (/ (setq d (distance pt1 pt2)) (* 2 (sin (/ (setq th (* 4 (atan a42))) 2)))) ; Radio del arco h ((if (> (abs th) PI) - +) (sqrt (- (* radio radio) (* (/ d 2) (/ d 2))))); Distancia del centro al punto medio aP (+ (angle pt1 pt2) (* (/ pi 2) (if (> a42 0) 1 -1))) ; Ángulo perpendicular centro (list (+ (/ (+ (car pt1) (car pt2)) 2) (* h (cos aP))) (+ (/ (+ (cadr pt1) (cadr pt2)) 2) (* h (sin aP)))) ) (list centro radio) ; Devuelve centro y radio ) (erroria) (if (setq se (entsel "\nSelect LWPOLYLINE...")) (if (= (cdr (assoc 0 (entget (setq e (car se))))) "LWPOLYLINE") (progn (setq c? (= (vla-get-closed (setq o (vlax-ename->vla-object (setq e (car se))))) :vlax-true) c?c (equal (vlax-curve-getPointAtParam o (vlax-curve-getStartParam o)) (vlax-curve-getPointAtParam o (setq pu (vlax-curve-getEndParam o))) 1e-6) p1 (fix (vlax-curve-getParamAtPoint o (vlax-curve-getClosestPointTo o (setq pS (cadr se))))) p2 (if (= p1 (1- pu)) (if c? 0 (1+ p1)) (1+ p1)) p0 (if (zerop p1) (if c? (1- pu)) (1- p1)) p3 (if (= p2 pu) (if (or c? c?c) 1) (1+ p2)) pt1 (vlax-curve-getPointAtParam o p1) pt2 (vlax-curve-getPointAtParam o p2) r (vlax-curve-getPointAtParam e (vlax-curve-getParamAtPoint o (vlax-curve-getClosestPointTo o pS))) pt0 (if p0 (vlax-curve-getPointAtParam o p0) (polar pt1 (+ (angle pt1 pt2) (/ PI 2.)) 100)) pt3 (if p3 (vlax-curve-getPointAtParam o p3) (polar pt2 (+ (angle pt1 pt2) (/ PI 2.)) 100)) a42 (cdr (assoc 42 (member (list 10 (car pt1) (cadr pt1)) (setq fe (entget e))))) ) (while (and (not para) (setq lgr (grread nil 13 0))) (if (or (member (cadr lgr) '(107 75)) (= (car lgr) 25) (not (listp (cadr lgr)))) (if (= (car lgr) 25) (setq para (entmod fe) bd T) (if (member (cadr lgr) '(107 75)) (setq *s* (not *s*)) ) ) (if (zerop a42) (setq d (distance (setq r1 (if *s* (progn (entmod fe) (setq para T dk (getreal "\nType the OFFSET distance (ENTER or RIGHT CLICK to indicate point on screen): ")) (getpoint r (if dk "\nSide to act on... " "\nPick a point on the screen... ")) ) (progn (prompt (strcat "\r " (if d (rtos d 2 3) "0.0") "...Press \'k\' to activate keyboard input...")) (cond ((= (car lgr) 5) (cadr lgr)) ((= (car lgr) 3) (setq para T) (cadr lgr)) ) ) ) ) (setq r (inters pt1 pt2 (polar r1 (setq a (+ (angle pt1 pt2) (/ PI 2.))) 3) (polar r1 (+ a PI) 3) nil)) ) px1 (inters pt0 pt1 (setq pa (polar pt1 (setq a ((asr pt1 r r1) (angle pt1 pt2) (/ pi 2.0))) (if dk dk d))) (setq pb (polar pt2 a (if dk dk d))) nil) px2 (inters pt2 pt3 pa pb nil) ) (setq ct-r (dameCentroRadio pt1 pt2 a42) d (- (distance (if *s* (progn (entmod fe) (setq para T dk (getreal "\nType the OFFSET distance (ENTER or RIGHT CLICK to indicate point on screen): ")) (getpoint r (if dk "\nSide to act on... " "\nPick a point on the screen... ")) ) (progn (prompt (strcat "\r " (if d (rtos (abs d) 2 3) "0.0") "...Press \'k\' to activate keyboard input...")) (cond ((= (car lgr) 5) (cadr lgr)) ((= (car lgr) 3) (setq para T) (cadr lgr)) ) ) ) (setq c (car ct-r)) ) (abs (cadr ct-r)) ) px1 (polar pt1 (angle (if (minusp d) pt1 c) (if (minusp d) c pt1)) (abs (if dk dk d))) px2 (polar pt2 (angle (if (minusp d) pt2 c) (if (minusp d) c pt2)) (abs (if dk dk d))) ) ) ) (if (not bd) (foreach l (list (list p1 (list (car px1) (cadr px1))) (list p2 (list (car px2) (cadr px2)))) (vla-put-coordinate o (car l) (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray 5 '(0 . 1)) (cadr l)))) ) ) ) ) (alert "No LWPOLYLINE selected") ) (alert "NOTHING selected") ) (princ) ) One last small improvement that displays the cursor offset in real time (command line) during the first phase of the command. A very useful little feature, I think.

Never stop thinking about problems, even when you are doing something outside.... Nice @GLAVCVS!

My effort... Just Text... ;;; Combine different overlapping text alphabetically. ;;; ;;; https://www.cadtutor.net/forum/topic/98013-is-it-possible-for-combining-different-texts-that-overlapping/#findComment-671805 ;;; ;;; By SLW210 (a.k.a. Steve Wilson) ;;; (defun c:CombTxtABC ( / ss i ent txts sorted-text result-text base-point) ;; Get string value (defun get-text-entity (ent) (cdr (assoc 1 (entget ent))) ) ;; Get insertion point (defun get-ins-point (ent) (cdr (assoc 10 (entget ent))) ) ;; Sort alphabetically (defun sort-by-text (a b) (if (equal (cadr a) (cadr b)) nil (if (or (null (cadr a)) (null (cadr b))) (null (cadr a)) (< (cadr a) (cadr b)) ) ) ) ;; Prompt user (setq ss (ssget '((0 . "TEXT")))) ; Only allow TEXT (not MTEXT) (if ss (progn (setq txts '()) ;; Loop through (setq i 0) (while (< i (sslength ss)) (setq ent (ssname ss i)) (if (and ent (eq (cdr (assoc 0 (entget ent))) "TEXT")) (setq txts (cons (list (get-ins-point ent) (get-text-entity ent) ent) txts)) ) (setq i (1+ i)) ) ;; Sort by content (setq sorted-text (vl-sort txts 'sort-by-text)) ;; Combine all (setq result-text "") (foreach text-item sorted-text (setq result-text (strcat result-text (cadr text-item))) ) ;; Insertion point from first text (setq base-point (car (car sorted-text))) ;; Create new TEXT with combined string (entmake (list (cons 0 "TEXT") (cons 8 "0") ; Layer (cons 10 base-point) (cons 40 1.0) ; Height (cons 1 result-text) (cons 7 "Standard") ; Text style (cons 72 1) ; Center justified (cons 11 base-point) ) ) ;; Delete original text (foreach text-item sorted-text (if (and (listp text-item) (cdr (assoc 0 (entget (caddr text-item))))) (entdel (caddr text-item)) ) ) (princ (strcat "\nCombined text: " result-text)) ) (princ "\nNo valid TEXT selected.") ) (princ) ) Text/MText... ;;; Combine different overlapping text/Mtext alphabetically. ;;; ;;; https://www.cadtutor.net/forum/topic/98013-is-it-possible-for-combining-different-texts-that-overlapping/#findComment-671805 ;;; ;;; By SLW210 (a.k.a. Steve Wilson) ;;; (defun c:CombTxt_MTxtABC ( / ss i ent txts sorted-text result-text base-point) ;; Get string value (defun get-text-entity (ent) (if (eq (cdr (assoc 0 (entget ent))) "MTEXT") (cdr (assoc 1 (entget ent))) ; For MTEXT (cdr (assoc 1 (entget ent))) ; For TEXT ) ) ;; Get insertion point (defun get-ins-point (ent) (cdr (assoc 10 (entget ent))) ) ;; Sort alphabetically (defun sort-by-text (a b) (if (equal (cadr a) (cadr b)) nil (if (or (null (cadr a)) (null (cadr b))) (null (cadr a)) (< (cadr a) (cadr b)) ) ) ) ;; Prompt user (setq ss (ssget '((0 . "TEXT,MTEXT")))) ; Allow both TEXT and MTEXT (if ss (progn (setq txts '()) ;; Loop through (setq i 0) (while (< i (sslength ss)) (setq ent (ssname ss i)) (if (and ent (or (eq (cdr (assoc 0 (entget ent))) "TEXT") (eq (cdr (assoc 0 (entget ent))) "MTEXT"))) (setq txts (cons (list (get-ins-point ent) (get-text-entity ent) ent) txts)) ) (setq i (1+ i)) ) ;; Sort by content (setq sorted-text (vl-sort txts 'sort-by-text)) ;; Combine all (setq result-text "") (foreach text-item sorted-text (setq result-text (strcat result-text (cadr text-item))) ) ;; Insertion point from first text (setq base-point (car (car sorted-text))) ;; Create new text with combined string (entmake (list (cons 0 "TEXT") (cons 8 "0") ; Layer (cons 10 base-point) (cons 40 1.0) ; Height (cons 1 result-text) (cons 7 "Standard") ; Text style (cons 72 1) ; Center justified (cons 11 base-point) ) ) ;; Delete original (foreach text-item sorted-text (if (and (listp text-item) (cdr (assoc 0 (entget (caddr text-item))))) (entdel (caddr text-item)) ) ) (princ (strcat "\nCombined (M)Text: " result-text)) ) (princ "\nNo valid Text or MText entities selected.") ) (princ) )

Another option, more respectful of the original format, could be to replace your Entmakex with this one. (entmakex (foreach as el (setq l (if (setq v (cond ((= (setq c (car as)) 0) '(0 . "TEXT")) ((member c '(8 1 40 50 7 72)) as) ((= c 71) (cons c (cadr (assoc (cdr as) '((1 2) (2 1) (3 0) (4 0) (5 0)))))) ((= c 73) '(73 . 2)) ((member c '(10 11)) (cons c p2)) ) ) (append l (list v)) l ) ) ) )

Hi The easiest way is to explode up the text. You can add at the end (vla-explode (vlax-ename->vla-object (setq eu (entlast)))) (entdel eu)

Nikon, I'd consider adding a check that a suitable text was selected, quick and dirty like this: ;;Loop till a mtext is selected. (while (not (equal (assoc 0 (entget (setq MyEnt (car (entsel "Select Mtext"))))) '(0 . "MTEXT") )) (princ "\nNo, Please ") ) Though of course if no mtext can be selected or the user changes their mind escape is the only way out so be wary of variables and error functions if needed. If the text strings are always short (under 250 characters) your code can be shortened to something like this I think. The second ssget you can use a wildcard "*TEXT" to get all text types. (defun c:test ( / ) ;;Loop till a mtext is selected. (while (not (equal (assoc 0 (entget (setq MyEnt (car (entsel "Select Mtext"))))) '(0 . "MTEXT") )) (princ "\nNo, Please ") ) ;;get text string. Assuming the search text is less than 250 characters else use another method (setq MyText (cdr (assoc 1 (entget myent)))) ;;get a selection set. Again assuming text strings less then 250 characters. (princ "\nNow select texts to search: ") (setq MySS (ssget (list (cons 0 "MTEXT")(cons 1 (strcat "*" MyText "*"))))) ;; do what you want here with MySS (princ) ) a slight different take on yours for longer texts which should work for LT too (defun c:test ( / MyText MySS FinalSS acount) ;;Loop till a mtext is selected. (while (not (equal (assoc 0 (entget (setq MyEnt (car (entsel "Select Mtext"))))) '(0 . "MTEXT") )) (princ "\nNo, Please ") ) (setq MyText (cdr (assoc 1 (entget myent)))) ;; selected text string ;;Get the texts to search. (princ "\nNow select texts: ") (setq MySS (ssget (list (cons 0 "*TEXT")))) ;; Loop through texts adding to selection set where text is found (setq acount 0) (setq FinalSS (ssadd)) (while (< acount (sslength MySS)) (setq MyEnt (entget (ssname MySS acount))) (if (or (wcmatch (strcase (cdr (assoc 1 MyEnt))) (strcat "*" (strcase Mytext) "*" )) ;; last 250 characters (if (cdr (assoc 3 MyEnt))(progn (wcmatch (strcase (cdr (assoc 3 MyEnt))) (strcat "*" (strcase Mytext) "*" )) ;; first 250 characers (wcmatch (strcase (cdr (assoc 3 MyEnt))) (strcat "*" (strcase Mytext) "*" )) ;; Middle 250 characters )) ; end if, end progn assoc 3 ) ; endor (progn ;; found (setq FinalSS (ssadd (ssname MySS acount) FinalSS) ) ) (progn ;; not found ) ) ; end if (setq acount (+ acount 1)) ) ; end while ;; do what you want here with found texts FinalSS )

Maybe this will help you (defun c:altObjs (/ cj a e l n at vlaObj) (if (setq a (getreal "\nNew height for (M)Texts/attributes: ")) (if (setq cj (ssget '((0 . "*TEXT,INSERT")))) (while (setq e (ssname cj (setq n (if n (1+ n) 0)))) (if (wcmatch (cdr (assoc 0 (setq l (entget e)))) "*TEXT") (entmod (subst (cons 40 a) (assoc 40 l) l)) (if (= (vla-get-hasAttributes (setq vlaObj (vlax-ename->vla-object e))) :vlax-true) (foreach at (vlax-safearray->list (variant-value (vla-getattributes vlaObj))) (vla-put-Height at a) ) ) ) ) ) ) (princ) )

Hi I understand that it's sorting based on the first number in each row Maybe this can help you (defun c:draganK (/ nmarch nmarch1 arch arch1 linea separa<->campos lst lstA v) (defun separa<->campos (tx lstCtrs / c p l) (foreach c (vl-string->list tx) (if (member (setq c (chr c)) lstCtrs) (if p (setq l (cons (atof p) l) p nil)) (setq p (if p (strcat p c) c)) ) ) (reverse (if p (cons (atof p) l) l)) ) (setvar "DIMZIN" 0) (if (setq nmarch (getfiled "Select source file" "" "*" 2 ) ) (if (setq arch (open nmarch "r")) (if (setq arch1 (open (setq nmarch1 (strcat (vl-filename-directory nmarch) "\\" (vl-filename-base nmarch) "_sorted" (vl-filename-extension nmarch) ) ) "w" ) ) (progn (while (setq linea (read-line arch)) (setq lst (separa<->campos linea '("," ";" " ")) lstA (cons lst lstA) ) ) (foreach v (vl-sort lstA '(lambda (a b) (< (car a) (car b)))) (write-line (foreach x v (setq s (if s (strcat s "\t" (rtos x 2 3)) (rtos x 2 3)))) arch1) (setq s nil) ) ) ) ) ) (if arch (close arch) ) (if arch1 (progn (close arch1) (startapp "notepad" nmarch1) ) ) (princ) )

@Marcin O An example of using entmakex to create the line: ;; Change this (command "_line" (list 10 end_x end_y 0) (list end2_x end2_y 0) "") ;; to this (entmakex (list '(0 . "LINE") (list 10 end_x end_y 0) (list 11 end2_x end2_y 0)))

@leonucadomi @PGia I'm attaching a new version V.3 that can also renumber block attributes. It also includes some other new features. However, I'm letting you know that <Something different> is going on 'holidays' and won't be serving any more requests for a while I'm attaching the description and new features of V.3: - Individual creation/renumbering of TEXTs and MTEXTs based on the cursor position - Multiple renumbering of TEXTs/MTEXTs via selection window (option key 'V') based on proximity to the first corner indicated on the screen of the selection window. That is: if the selection window is from Northwest to Southeast, the renumbering increment will be in order from least to greatest distance from the Northwest corner Added in this version: - Ability to detect and renumber block attributes using the same criteria as 'TEXT' and 'MTEXT' attributes. (Note: This may not work for block attributes with multiple levels of nesting.) - New functionality (by pressing the 'A' key) to change text alignment on the fly. A preview of how it works: SDifferent_V3.mp4 SDifferent_V3.lsp

@EIA You can use a dynamic block. А-А.dwg

Why not something different...? ;************************ G L A V C V S ************************* ;************************** F E C I T *************************** (defun c:txtIncrem (/ tam capa ind para a txsel lstent le l s dameTexto errores error0) (defun errores (mens) (setq *error* error0) (prin1) ) (defun dameTexto (/ tx) ;;; WRITE HERE THE CODE YOU NEED TO CUSTOMIZE THE TEXT YOU WANT TO ENTER OR CREATE (cond ((= (strlen (setq tx (itoa (setq ind (+ ind 1))))) 1) (strcat "00" tx) ) ((= (strlen tx) 2) (strcat "0" tx) ) (T tx) ) ) (while (not para) (if (setq ent (car (entsel "\nSelect index text..."))) (if (= (cdr (assoc 0 (setq lstent (entget ent)))) "TEXT") (if (wcmatch (setq ind (cdr (assoc 1 lstent))) "#,##,###,####") (setq ind (atoi ind) capa (cdr (assoc 8 lstent)) a (cdr (assoc 40 lstent)) para T) (princ "\n*** The selected object is not valid. Please, try again... ***") ) ) (setq para T) ) ) (setq error0 *error* *error* errores ) (setq tam (* (getvar "pickbox") (/ (GETVAR "VIEWSIZE") (CADR (GETVAR "SCREENSIZE")))) para nil) (princ "\nSelect text to modify or insert new text (RIGHT CLICK for exit)...") (while (and (setq l (grread T (if s 4 13) (if s 2 0))) (member (car l) '(5 3))) (if (setq s (ssget "_C" (list (- (car (setq p (cadr l))) tam) (- (cadr p) tam)) (list (+ (car p) tam) (+ (cadr p) tam)) (list (cons 0 "TEXT")) ) ) (cond ((= (car l) 3) (entmod (subst (cons 1 (dameTexto)) (assoc 1 (setq le (entget (ssname s 0)))) le)) ) ;Here are other possible cases ) (cond ((= (car l) 3) (entmake (list '(0 . "TEXT") (cons 8 capa) (cons 40 a) (cons 1 (dameTexto)) (cons 10 (list (car p) (cadr p) 0.0)) ) ) ) ;Here are other possible cases ) ) ) (princ) )

Where layer transparency is concerned, this may be of interest - https://www.theswamp.org/index.php?topic=52473.msg574001#msg574001

;;; blocks in group (defun c:big ( / gl ) (vl-load-com) (if (not (vl-consp (setq gl (lag)))) (alert "Computer says no : there are no groups") ;;; show all blocks in group (choose from group list) (sabig (cfl gl)) ) (princ) ) ;;; list all groups (setq rtn (lag)) (defun lag ( / gps lst) (setq gps (vla-get-groups (vla-get-activedocument (vlax-get-acad-object)))) (vlax-for g gps (setq lst (cons (vla-get-name g) lst))) (if (vl-consp lst) (acad_strlsort lst)) ) ; choose from list (cfl '("1""2""3")) (defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p) (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d) (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)") (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)") (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil))) ;;; display list (plus message) (defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l)))) (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";" "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb") (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f)))) ; multiple association (defun massoc ($i $l / a l)(while (setq a (assoc $i $l))(setq l (cons (cdr a) l) $l (cdr (member a $l))) l)) ;;; test if (vla) object is a block / get blockname / ename->vla-object (defun block-p (o) (and (setq o (e->o o)) (member (vla-get-objectname o) '("AcDbBlockReference" "AcDbBlockTableRecord")))) (defun block-n (o) (if (block-p o)(if (vlax-property-available-p o 'EffectiveName)(vla-Get-EffectiveName o)(vla-Get-Name o)))) (defun e->o (e) (cond ((= 'vla-object (type e)) e)((= 'ename (type e))(vlax-ename->vla-object e))(t nil))) ;;; show all blocks in group (defun sabig (gname / odic gdic grec el blist) (setq odic (namedobjdict)) (setq gdic (dictsearch odic "ACAD_GROUP")) (setq grec (dictsearch (cdar gdic) gname)) (setq el (massoc 340 grec)) (if (vl-consp el) (foreach x el (if (block-p x)(setq blist (cons (block-n (e->o x)) blist))))) (if (vl-consp blist) ;;; (dplm (acad_strlsort blist) (strcat "Blocks in group " gname)) (write-list blist) (alert (strcat "Computer says no : sorry no block in group " gname)) ) ) (defun write-list ( l / fn fp) (if (setq fp (open (setq fn (strcat (getvar "dwgprefix") "file1.txt")) "w")) (progn (foreach item l (write-line item fp)) (close fp) (gc) (gc) (startapp "notepad" fn) ) ) (princ) )

https://www.theswamp.org/index.php?topic=51248.msg563608#msg563608