Leaderboard

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

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.

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

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

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

I always try to avoid using command when I can. entmakex is faster and doesn't output to the command line. wrapping with setq you can even save the entity or add to selection set. (setq pts (list p1 p2 p3 p4)) (setq trap (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1)) (mapcar '(lambda (p) (cons 10 p)) pts) ) ) ) (sssetfirst nil (ssadd trap))

Everything SLW210 has researched is very interesting. I had no idea this had been such a thoroughly discussed topic — and with such limited success. I guess that makes it even more interesting. In my opinion, it is possible to obtain a center polyline that is equidistant from both edges. But two conditions must be met: 1. The user must ensure that the geometry of both edges is correct: they must be 2D polylines with no repeated points and no geometric inconsistencies of any kind. And, in principle, to avoid extending the search for a solution, these polylines should not contain arcs. 2. One must accept that any edge containing “recesses” (“recodos”) must be handled using auxiliary axes. What is a recess? It is a geometric setback, in any direction, along one of the edges. For example: if you advance segment by segment along an edge (in either direction), the start of a recess would be defined as any vertex from which the shortest distance to the opposite edge forces the projection to intersect its own edge. My conclusion: for edges without recesses, I believe it is possible to find an equidistant centerline or axis. And for edges with recesses, although considerably more code will be needed, they should be solvable using auxiliary axes. I hope to have code soon that supports all of this.

I made some changes so it also works when the starting lines are intersecting. Cool to see lots of people try to solve this problem! Mine doesn't work well with parallel lines and doesn't generate arcs. It still looks like GP_'s solution has the best result for me, but for intersecting lines I have to execute the function twice and select the lines in two directions to get the full result. centerline.lsp

Thought we were getting tolled when i saw @GP_ GIF had to double take on the original posted dwg.

Seneca said: “Homines dum docent discunt.” Which, roughly, means: Learn to explain and explain to learn

It will require more modification than just extending the bulge list - you also need to calculate the positions of the additional vertices. However, I really liked your suggestion (and it's also consistent with my existing Box Text program), and so I've updated the program to Version 1.3 to incorporate a new Filleted Rectangle textbox option (you may need to refresh the page to view the new version). Enjoy!

I guess you could do like (setq i (+ i 0.01)) 16 vertex poly would then create a 1600 vertex poly And then run overkill on the created polyline to remove all collinear vertexes.

I think you're doing a very good job. PS: The animation in the GIF doesn't look the same as the one in the code.

I'm still sorting an attempt at the Bowyer–Watson version, but first I am trying to sort a few that are getting close. The export CSV and import a centerline is very close, but on the AxisExample .dwg it has a zig-zag glitch. I have one that draws the bisector lines that's close, but still misses the midpoint coming around those turns. I do have the one that appears very accurate on bends in one direction and the bends in the opposite direction depending on pick order. This would work if the AxisExample.dwg was in separate sections at the turns, maybe. I get a error: bad argument type: fixnump: nil with the AxisExample.dwg and some other errors on the original Example.dwg (Two vertices were added to a 2D pline (0) which had no vertices. and error: bad argument type: numberp: nil ) though the simple ones it draws the centerline with @marko_ribar's version. Every one of these fall short on the OPs AxisExample drawing, most in the same areas. So, I will probably keep at this for a while to see how close I can get it. For sure, nearly everyone of these are as good as and many much better than, the currently available solutions in AutoCAD. The solution suggested by Autodesk, PathAverage.lsp by Kent Cooper, fails miserably on most of the OP's examples, though seems to work in most cases and needs the polylines in the same direction. I still have work to do for my paying job, but hopefully I can bang out something soon.

For fun, an another old code (in French) trapeze_dyn.lsp

If you want 30 degree use (* (/ 1.0 6.0) pi) My $0.05 the front end can preset values but change as required. (if (not AH:getvalsm)(load "Multi Getvals.lsp")) (setq ans (AH:getvalsm (list "Enter Values" "Base Width " 5 4 "100" "Height " 5 4 "100" "Angle" 5 4 "30" ))) (setq Wid (atof (nth 0 ans)) ht (atof (nth 1 ans)) ang (atof (nth 2 ans))) (setq ang (* pi (/ ang 180.0))) Multi GETVALS.lsp

@Nikon IMHO - the extra variables that mhupp referenced in his example are unnecessary, and you didn't localize them. I'd recommend you simplify to this: (defun c:trapezoid (/ bw p0 p1 p2 p3 p4 ra sa th) (if (and (setq bw (getreal "\nEnter the width of the Base: ")) (setq th (getreal "\nEnter the Height: ")) (setq sa (getreal "\nEnter the side angles: ")) (setq p0 (getpoint "\nSelect the insertion point: ")) ) (progn (setq ra (* pi (/ sa 180.0)) p1 (list (- (car p0) (/ bw 2)) (cadr p0) (caddr p0)) p2 (list (+ (car p1) bw) (cadr p0) (caddr p0)) p3 (list (+ (car p2) (* (/ th (cos ra)) (sin ra))) (+ (cadr p0) th) (caddr p0)) p4 (list (- (car p1) (* (/ th (cos ra)) (sin ra))) (+ (cadr p0) th) (caddr p0)) ) (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1)) (mapcar '(lambda (x) (cons 10 x)) (list p1 p2 p3 p4)) ) ) ) ) )

@mhupp that works fine. I personally think the benefits are extremely tiny on such a simple code form. For short routines, I tend to just use the command sequence. On more intensive stuff I use the ActiveX entity creation more often then using entmake with DXF codes.

Here's my quick version: (defun c:trapezoid (/ bw p0 p1 p2 p3 p4 ra sa th) (if (and (setq bw (getreal "\nEnter the width of the Base: ")) (setq th (getreal "\nEnter the Height: ")) (setq sa (getreal "\nEnter the side angles: ")) (setq p0 (getpoint "\nSelect the insertion point: ")) ) (progn (setq ra (* pi (/ sa 180.0)) p1 (list (- (car p0) (/ bw 2)) (cadr p0) (caddr p0)) p2 (list (+ (car p1) bw) (cadr p0) (caddr p0)) p3 (list (+ (car p2) (* (/ th (cos ra)) (sin ra))) (+ (cadr p0) th) (caddr p0)) p4 (list (- (car p1) (* (/ th (cos ra)) (sin ra))) (+ (cadr p0) th) (caddr p0)) ) (command-s "._pline" "_non" p1 "_non" p2 "_non" p3 "_non" p4 "_c") ) ) )

I think you should rename the variable 'angle': 'angle' is a language symbol, that is, a function. Try changing it to 'ang', for example.

You can limit what ssget selects by entity, layer, color, size, basically anything in dxf codes. please read up on ssget This means you could just make a window selection. And not have to zoom in and out to make selections. also @Steven P already said "ssadd does a check if the entity exists in the set" check the length of SS before and after to see if it was already in the list. also also looks like your not using localized variables could be why its taking so long. (defun C:123 ( / ss pick l) (setq ss (ssadd)) (princ "\nSelect Entity: ") (while (setq pick (ssget)) (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex pick))) (setq l (sslength ss)) ; Length before adding (setq ss (ssadd ent ss)) ; Try adding entity (if (= l (sslength ss)) ; If length is the same, item was already in list (princ "\n\nDuplicate Selected Line") ) ) (princ (strcat "\n" (itoa (sslength ss)) " Entities now in Selection SS")) ) ; rest of code goes here (princ) ) (defun C:bm ( / ss ent) (while (setq SS (ssget (ssget "_+.:E:S"))) ;exits if selection isn't made (setq ent (ssname ss 0)) ;CODE ) )

Case 1: ssadd does a check if the entity exists in the set, you can change CASE 1 (setq ss (ssadd)) (if (not (ssmemb n ss)) (ssadd n ss) ;code );if to CASE 1 (ssadd n ss) ;code Often in code optimisation is rarely a single line that makes a difference... unless you are doing thousands of calculations, so here taking out an if statement won't do a lot. Most likely you have a loop within a loop that slows things - might be more efficient to look back at how you are selecting the entities and processing them before adding to the selection set. However don't just accept that, if you code will work without the line take out your if statement, and ssadd and you shouldn't really notice a big difference in speed

See if this works will tweek it tonight if something throws error. Modified version of my last code Ask user to select first and 2nd polyline Find mid points from each vertex of poly1 to poly 2 with vlax-curve-getClosestPointTo Adds those points to a dotted pair with the vertex number Creates a temp polyine with those points Find minpoints from each vertex of poly2 to poly one with vlax-curve-getClosestPointTo Processed the 2nd list of points using vlax-curve-getClosestPointTo to temp polyline Using that with vlax-curve-getParamatpoint will tell where on the tempoly if falls Sort polylist by the parma so they will be in order and removing the parama so only point data is left Delete temp polyline Create new mid polyline with all points in right order. Stuff that is doing the heavy lifting is vlax-curve-getClosestPoint and vlax-curve-getParamatpoint. this will work with polylines with arc's but will only generate a mid polyline using straight lines. Everything you post they don't seem to have any arcs so you should be good. ;;----------------------------------------------------------------------------;; ;; POLY AVERAGE path between polylines, Finds the mid path (defun c:PA () (C:POLYAVG)) (defun c:POLYAVG (/ ent1 ent2 i tol ptv ptc par mid pts1 pts2 polylst tempoly) (setq ent1 (car (entsel "\nSelect first polyline: "))) (if (not (and ent1 (= (cdr (assoc 0 (entget ent1))) "LWPOLYLINE"))) (progn (princ "\nInvalid 1st selection.") (exit) ) (setq ent1 (vlax-ename->vla-object ent1)) ) (setq ent2 (car (entsel "\nSelect 2nd polyline: "))) (if (not (and ent2 (= (cdr (assoc 0 (entget ent2))) "LWPOLYLINE"))) (progn (princ "\nInvalid first selection.") (exit) ) (setq ent2 (vlax-ename->vla-object ent2)) ) (if (and ent1 ent2) (progn (setq pts1 '()) (setq i 0) (setq tol (fix (vlax-curve-getEndParam ent1))) (while (<= i tol) (setq ptv (vlax-curve-getPointAtParam ent1 i)) (setq ptc (vlax-curve-getClosestPointTo ent2 ptv)) ;(entmake (list '(0 . "LINE") '(8 . "0") (cons 10 ptv) (cons 11 ptc))) (setq mid (mapcar '/ (mapcar '+ ptv ptc) '(2 2 2))) (setq pts1 (append pts1 (list mid))) (setq polylst (cons (cons mid i) polylst)) (setq i (1+ i)) ) (setq Flag (if (= (vla-get-Closed ent1) :vlax-true) 1 0)) ; Get closed status (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length pts1)) (cons 70 flag) ) (mapcar '(lambda (p) (cons 10 p)) pts1) ) ) (setq tempoly (entlast)) (setq pts2 '()) (setq i 0) (setq tol (fix (vlax-curve-getEndParam ent2))) (while (<= i tol) (setq ptv (vlax-curve-getPointAtParam ent2 i)) (setq ptc (vlax-curve-getClosestPointTo ent1 ptv)) ;(entmake (list '(0 . "LINE") '(8 . "0") (cons 10 ptv) (cons 11 ptc))) (setq mid (mapcar '/ (mapcar '+ ptv ptc) '(2 2 2))) (setq pts2 (append pts2 (list mid))) (setq i (1+ i)) ) (foreach pt pts2 (setq ptv (vlax-curve-getClosestPointTo tempoly pt)) (setq Par (vlax-curve-getParamatpoint tempoly ptv)) (setq polylst (cons (cons pt par) polylst)) ) (setq polylst (mapcar 'car (vl-sort polylst '(lambda (a b) (< (cdr a) (cdr b)))))) (entdel tempoly) (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length polylst)) (cons 70 flag) ) (mapcar '(lambda (p) (cons 10 p)) polylst) ) ) (princ "\nNew midpoint polyline created.") ) (princ "\nSelection error.") ) (princ) ) -Edit Still a little janky but you can see why if you un-comment the entmake lines

I also think this thread has been stimulating. The final result should be useful for other users in the future. Regarding your approach, I agree; it's the best way to achieve an axis with perfectly centered segments. All that remains is to write the code that can do all of that without Express Tools.

Coming back to this one: Annotative Text, I find that I have to create the text style and then add the extended data to convert it to annotative text Handy that this can have an if loop in it and be used to create either normal or annotative if you want to adjust it: (defun c:MakeAnnoFont ( FontName FontStyle / Height NewFontEnt exdata newent ) (setq Height 0) (setq NewFontEnt (entmakex (list '(0 . "STYLE") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbTextStyleTableRecord") (cons 2 FontName) '(70 . 0) (cons 40 Height) '(41 . 1.0) '(50 . 0.0) '(71 . 0) (cons 42 Height) (cons 3 FontStyle) ;; Font style to include suffix e.g. '.ttf' or '.shx' '(4 . "") ))) ; end entmakex, end list, end setq ;;Add xdata - annotative text (regapp "AcadAnnotative") (setq exdata '((-3 ("AcadAnnotative" (1000 . "AnnotativeData") (1002 . "{") (1070 . 1) (1070 . 1) (1002 . "}") ) ; new extended data— )) ) (setq newent (append (entget NewFontEnt) exdata)) ; Appends new data list to entity's list. (entmod newent) ; Modifies the entity with the new definition data. (princ) ) I don't use a lot of annotative dimensions to make a LISP worthwhile, but reading this week I think the method is the same, create the dimension and then add the xdata to it afterwards. Most of my dimension LISPs started off from here: https://stackoverflow.com/questions/47835301/use-autolisp-to-generate-new-dimension-style Though from BigAl, I think this one sets all the dimension stuff ; https://www.cadtutor.net/forum/topic/56889-entmake-for-dimension-styles/ ; BigAl ; DimStyle Create ; (defun DSTYLE_DIMSTYLE_CREATE (DSTY$ DSCL# AH$ FSTY$) (if (null (tblsearch "dimstyle" DSTY$)) (progn (entmakex (list (cons 0 "DIMSTYLE") ; Entity Type (cons 100 "AcDbSymbolTableRecord") ; Subclass marker (cons 100 "AcDbDimStyleTableRecord") ; Subclass marker (cons 2 DSTY$) ; Dimstyle name (cons 70 0) ; Standard flag value (cons 3 "") ; DIMPOST (cons 4 "") ; DIMAPOST (cons 5 AH$) ; DIMBLK (cons 6 AH$) ; DIMBLK1 (cons 7 AH$) ; DIMBLK2 (cons 40 DSCL#) ; DIMSCALE (cons 41 0.0937) ; DIMASZ (cons 42 0.0937) ; DIMEXO (cons 43 0.38) ; DIMDLI (cons 44 0.0625) ; DIMEXE (cons 45 0.0) ; DIMRND (cons 46 0.0625) ; DIMDLE (cons 47 0.0) ; DIMTP (cons 48 0.0) ; DIMTM (cons 140 0.0937) ; DIMTXT (cons 141 0.09) ; DIMCEN (cons 142 0.0) ; DIMTSZ (cons 143 25.4) ; DIMALTF (cons 144 1.0) ; DIMLFAC (cons 145 0.0) ; DIMTVP (cons 146 1.0) ; DIMTFAC (cons 147 0.0625) ; DIMGAP (cons 71 0) ; DIMTOL (cons 72 0) ; DIMLIM (cons 73 0) ; DIMTIH (cons 74 0) ; DIMTOH (cons 75 0) ; DIMSE1 (cons 76 0) ; DIMSE2 (cons 77 0) ; DIMTAD (cons 78 3) ; DIMZIM (cons 170 0) ; DIMALT (cons 171 2) ; DIMALTD (cons 172 0) ; DIMTOFL (cons 173 0) ; DIMSAH (cons 174 0) ; DIMTIX (cons 175 0) ; DIMSOXD (cons 176 1) ; DIMCLRD (cons 177 1) ; DIMCLRE (cons 178 2) ; DIMCRRT (cons 270 4) ; DIMUNIT (cons 271 4) ; DIMDEC (cons 272 4) ; DIMTDEC (cons 273 2) ; DIMALTU (cons 274 2) ; DIMALTTD (cons 275 0) ; DIMAUNIT (cons 276 2) ; DIMFRAC (cons 277 4) ; DIMLUNIT (cons 279 2) ; DIMTMOVE (cons 280 0) ; DIMJUST (cons 281 0) ; DIMSD1 (cons 282 0) ; DIMSD2 (cons 283 1) ; DIMTOLJ (cons 284 0) ; DIMTZIN (cons 285 0) ; DIMALTZ (cons 286 0) ; DIMALTTZ (cons 287 5) ; DIMFIT (cons 288 0) ; DIMUPT (cons 340 (tblobjname "style" FSTY$)) ; DIMTXSTY (cons 342 (cdr (assoc 330 (entget (tblobjname "block" AH$))))); DIMLDRBLK (cons 343 (cdr (assoc 330 (entget (tblobjname "block" AH$))))); DIMLDRBLK1 (cons 344 (cdr (assoc 330 (entget (tblobjname "block" AH$))))); DIMLDRBLK2 ) ) ) ) And I'll give you 'Jeff' which has a better description of the one above Jeff just adjusts dimension font style, text height, and colours. Arrows are set at 2x font height I think - from the stackoverflow link above (defun c:jeff ( / DimStyleName DSN FontStyleName FSN FontHeight TxtCol LinCol Col TxtPrecision TxtPrec) ;;change dimension style ;;Dimension Style (princ "\nEnter Dimension style Name ")(princ (tableSearch "dimstyle")) (setq DimStyleName (getvar "dimstyle")) (setq DSN (getstring (strcat ": (" DimStyleName "): ") t)) (if (or (= DSN nil)(= DSN "")) (setq DimStyleName DimStyleName) (setq DimStyleName DSN) ) (princ DimStyleName) ;;Font Style (princ "\nEnter Font style Name ")(princ (tableSearch "style")) ;; (setq FontStyleName (nth 0 (tableSearch "style"))) (setq FontStyleName (getvar "textstyle")) (setq FSN (getstring (strcat " (" FontStyleName "): ") t)) (if (or (= FSN nil)(= FSN "")) (setq FontStyleName FontStyleName) (setq FontStyleName FSN) ) (princ FontStyleName) ;;Font Height (setq FontHeight 2.5) ;; How to get this from dimstyle selected above (setq FontHght (getreal (strcat "\nEnter Font Height [" (rtos FontHeight)"]: "))) (if (or (= FontHght nil)(= FontHght "")) (setq FontHeight FontHeight) (setq FontHeight FontHght) ) (princ FontHeight) ;;Colours (setq TxtCol 0) ;Text. 0: By Layer, 256: ByBlock (setq Col (getint (strcat "\nEnter Text Colour Code (0: ByLayer, 256: ByBock) [" (rtos TxtCol)"]: "))) (if (or (= Col nil)(= Col "")) (setq TxtCol TxtCol) (setq TxtCol Col) ) (princ TxtCol) (setq LinCol 0) ;Lines. 0: By Layer, 256: ByBlock (setq Col (getint (strcat "\nEnter Lines Colour Code (0: ByLayer, 256: ByBock) [" (rtos LinCol)"]: "))) (if (or (= Col nil)(= Col "")) (setq LinCol LinCol) (setq LinCol Col) ) (princ LinCol) ;;Precision (setq TxtPrecision 4) ; number of decimal places ;; How to get this from dimstyle selected above (setq TxtPrec (getint (strcat "\nEnter Decimal Places) [" (rtos TxtPrecision) "]: "))) (if (or (= TxtPrec nil)(= TxtPrec "")) (setq TxtPrecision TxtPrecision) (setq TxtPrecision TxtPrec) ) (princ TxtPrecision)(princ " DP") (setq DimensionScale (/ FontHeight 2.5)) (jeff1 DimStyleName FontStyleName FontHeight TxtCol LinCol TxtPrecision DimensionScale) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun jeff1 ( DimStyleName FontName FontHeight TxtCol LinCol TxtPrecision DimensionScale / ) ;;Sub Routines (defun mytextstyle ( myfont / mytextstyle fontcount fontlist) ;;check textstyle is loaded ;;Font Style Lists ;;Fontname Height WidthFactor ObliqueAngle Backwards UpsideDown (setq fontstyles (list (list "Standard" "Arial" "0.0000" "1.0000" "0" "No" "No") (list "romans" "romans.shx" "0.0000" "1.0000" "0" "No" "No") ;;Add your own font definitions here ));end fontstyles list (if (member myfont (tableSearch "style")) (princ "Font Is Loaded") (progn ; Font isn't loaded (setq fontcount 0) (while (< fontcount (length fontstyles)) (if (= (strcase (nth 0 (nth fontcount fontstyles))) (strcase myfont)) (progn ;font style is loaded (setq fontlist fontcount) ;;font style exists ) ; end progn ) ;end if (setq fontcount (+ 1 fontcount)) ) (if (= fontlist nil) (progn ;;if font is not defined above or loaded (alert "Font style needs loading. Please edit it") (command "Style" myfont "romans.shx" "0.0000" "1.0000" "0" "No" "No" "No") (initdia) (command "style") ) ;end progn (progn (command "style" (nth 0 (nth fontlist fontstyles)) (nth 1 (nth fontlist fontstyles)) (nth 2 (nth fontlist fontstyles)) (nth 3 (nth fontlist fontstyles)) (nth 4 (nth fontlist fontstyles)) (nth 5 (nth fontlist fontstyles)) (nth 6 (nth fontlist fontstyles)) (nth 7 (nth fontlist fontstyles)) ) ;end command ) ;end progn ) ;end if ) ;end progn );end if (setq mystyle myfont) ;;text font style.. if anything else check if style is loaded into drawing here mystyle ) ;;End Sub Routines (mytextstyle FontName) ;; Check Font exists else make it ;;Full list of dimension variables. ;;Change all or none as required, save and existing style to update ;;NOTE: BYBLOCK and other texts to be numbers? ;;https://help.autodesk.com/view/ACDLTM/2016/ENU/?guid=GUID-30F44A49-4250-42D1-AEF2-5E2914ADB02B ;; List value ;; Default ;;Description (setvar "DIMADEC" TxtPrecision) ;; 0 ;;Angular Dimension Decimal Places ; (setvar "DIMALT" 0) ;; 0 ;;Control of alternative units 0 - Off 1 - On (setvar "DIMALTD" TxtPrecision) ;; 2 / 3 ;;Alternative Units Decimal Places ; (setvar "DIMALTF" 0.0394) ;; 25.4 / 0.0394 ;;Alternative Units Scale Factor ;;(setvar "DIMALTMZF") ;; ;;Alternate sub-zero factor for metric dimensions - Unknown variable ;;(setvar "DIMALTMZS") ;; ;;Alternate sub-zero suffix for metric dimensions - Unknown variable ; (setvar "DIMALTRND" 0.00) ;; 0.00 ;;Alternate units rounding value ; (setvar "DIMALTTD" 3) ;; 2 / 3 ;;Alternative Units Tolerance Decimal Places ; (setvar "DIMALTTZ" 0) ;; 0 ;;Alternate tolerance zero suppression ; (setvar "DIMALTU" 2) ;; 2 ;;Alternative Units Units ; (setvar "DIMALTZ" 0) ;; 0 ;;Alternate unit zero suppression ; (setvar "DIMAPOST" "") ;; "" ;;Prefix and suffix for alternate text ; (setvar "DIMARCSYM" 0) ;; 0 ;;Arc Length Dimension Arc Symbol (setvar "DIMASZ" FontHeight) ;; 0.18 / 2.5 ;;Dimension Line and Leader Line Arrow Heads size ; (setvar "DIMATFIT" 3) ;; 3 ;;Arrow and text fit if distance is too narrow for both ; (setvar "DIMAUNIT" 0) ;; 0 ;;Angular unit format ; (setvar "DIMAZIN" 0) ;; 0 ;;Angular Dimension Depresses leading zeros ; (setvar "DIMBLK" ".") ;; "." ;;Arrow block name "." for closed flled else as properties ; (setvar "DIMBLK1" ".") ;; "." ;;First arrow block name "." for closed flled else as properties ; (setvar "DIMBLK2" ".") ;; "." ;;Second arrow block name "." for closed flled else as properties (setvar "DIMCEN" FontHeight) ;; 0.09 / 2.5 ;;Drawing centre mark for radius or diameter dimensions (setvar "DIMCLRD" LinCol) ;; 0 ;;Colours - Lines, ArrowHeads, Dimension Lines 0: ByLayer, 256 ByBlock (setvar "DIMCLRE" LinCol) ;; 0 ;;Colours - Extension Lines, Centre Marks Colours 0: ByLayer, 256 ByBlock (setvar "DIMCLRT" TxtCol) ;; 0 ;;Colours - Dimension Text Colour 0: ByLayer, 256 ByBlock (setvar "DIMDEC" TxtPrecision) ;; 0 ;;Dimension Decimal Places ; (setvar "DIMDLE" 0) ;; 0.0000 ;;Dimension Line extension with oblique strokes instead of arrows ; (setvar "DIMDLI" 4) ;; 3.75 ;;Dimension Baseline Dimension Spacing (setvar "DIMDSEP" ".") ;; . ;;Decimal separator (setvar "DIMEXE" (/ Fontheight 2)) ;; 0.18 / 1.25 ;;Extension Line Extension distance (setvar "DIMEXO" (/ Fontheight 4)) ;; 0.0625 / 0.625 ;;Extension Line Offset ; (setvar "DIMFRAC" 0) ;; 0 ;;Dimension Fraction Format ; (setvar "DIMFXL" 1.00) ;; 1 ;;Fixed Extension Line ; (setvar "DIMFXLON" 0) ;; 0 ;;Enable Fixed Extension Line 0 - Off 1 - On (setvar "DIMGAP" (/ FontHeight 4)) ;; 0.09 / 0.625 ;;Dimension gap between text and arrow (setvar "DIMJOGANG" (* pi (/ 45 180.0))) ;; ;;Radius dimension jog angle.. radians? ; (setvar "DIMJUST" 0) ;; 0 ;;Justification of text on dimension line (setvar "DIMLDRBLK" ".") ;; "." ;;Leader block name "." for closed flled else as properties ; (setvar "DIMLFAC" 1.00) ;; 1 ;;Linear unit scale factor ; (setvar "DIMLIM" 0) ;; 0 ;;Generate dimension limits 0 - Off 1 - On (setvar "DIMLTEX1" "BYBLOCK") ;; "." ;;Linetype extension line 1 (setvar "DIMLTEX2" "BYBLOCK") ;; "." ;;Linetype extension line 2 (setvar "DIMLTYPE" "BYBLOCK") ;; "." ;;Dimension linetype ; (setvar "DIMLUNIT" 2) ;; 2 ;;Dimension Units (except angular) - number type ; (setvar "DIMLWD" -2) ;; -2 ;;Dimension Line Lineweights ; (setvar "DIMLWE" -2) ;; -2 ;;Extension Line Line Weight ;;(setvar "DIMMZF") ;; ;;Sub-zero factor for metric dimensions - Unknown variable ;;(setvar "DIMMZS") ;; ;;Sub-zero suffix for metric dimensions - Unknown variable ; (setvar "DIMPOST" "") ;; "" ;;Prefix and suffix for dimension text ; (setvar "DIMRND" 0) ;; 0 ;;Dimension Round distance to nearest n ; (setvar "DIMSAH" 0) ;; 0 ;;Separate arrow blocks 0 - Off 1 - On ; (setvar "DIMSCALE" 1) ;; 1 ;;Dimension Scale Factor ; (setvar "DIMSD1" 0) ;; 0 ;;Suppress the first dimension line 0 - Off 1 - On ; (setvar "DIMSD2" 0) ;; 0 ;;Suppress the second dimension line 0 - Off 1 - On ; (setvar "DIMSE1" 0) ;; 0 ;;Suppress the first extension line 0 - Off 1 - On ; (setvar "DIMSE2" 0) ;; 0 ;;Suppress the second extension line 0 - Off 1 - On ; (setvar "DIMSOXD" 0) ;; 0 ;;Suppress outside dimension lines ; (setvar "DIMTAD" 0) ;; 0 ;;Dimension Text Vertical distance ; (setvar "DIMTDEC" 4) ;; 4 ;;Tolerance decimal places ; (setvar "DIMTFAC" 1) ;; 1 ;;Dimension text scale factor of fractions relative to text height ; (setvar "DIMTFILL" 0) ;; 0 ;;Text background enabled ; (setvar "DIMTFILLCLR" 0) ;; 0 ;;Text background color 0: ByLayer, 256 ByBlock ; (setvar "DIMTIH" 0) ;; 0 ;;Text inside extensions is horizontal 0 - Off 1 - On ; (setvar "DIMTIX" 0) ;; 0 ;;Place text inside extensions 0 - Off 1 - On ; (setvar "DIMTM" 0) ;; 0 ;;Dimension Minus tolerance distance when used with dimtol, or dimlim ; (setvar "DIMTMOVE" 0) ;; 0 ;;Text movement ; (setvar "DIMTOFL" 0) ;; 0 ;;Force line inside extension lines 0 - Off 1 - On ; (setvar "DIMTOH" 1) ;; 1 ;;Text outside horizontal 0 - Off 1 - On ; (setvar "DIMTOL" 0) ;; 0 ;;Tolerance dimensioning 0 - Off 1 - On ; (setvar "DIMTOLJ" 1) ;; 0 ;;Tolerance vertical justification ; (setvar "DIMTP" 0) ;; 0 ;;Dimension Plus tolerance distance when used with dimtol, or dimlim ; (setvar "DIMTSZ" 0.00) ;; 0 ;;Tick size ; (setvar "DIMTVP" 0.00) ;; 0 ;;Text vertical position (setvar "DIMTXSTY" FontName) ;; Font ;;Text style (setvar "DIMTXT" FontHeight) ;; 0.18 / 2.5 ;;Dimension text Height ;;(setvar "DIMTXTDIRECTIONOff" 0) ;; ;;Dimension text direction 1 or 0 - NOT SURE IF THIS WORKS ; (setvar "DIMTZIN" 8) ;; 8 ;;Suppresses leading zeros in tolerance values ; (setvar "DIMUPT" 0) ;; 0 ;;User positioned text 0 - Off 1 - On ; (setvar "DIMZIN" 8) ;; 8 ;;Suppresses leading zeroes ;;Set Dimstyle named above to this list (setq dimstylelist (tableSearch "dimstyle")) (if (= (member DimStyleName dimstylelist) nil) (command "dimstyle" "s" DimStyleName) (command "dimstyle" "s" DimStyleName "Y") ) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Hope that sets you on your way a little Edit: Last snippet. If you want to get the entity name of a font style, which you can apply to the add xdata portion from my first code to add annotative to an existing font. (defun c:GetTextStyle ( FontName / ) (Entget (tblobjname "style" FontName)) ;;(entget (tblobjname "Style" FontName) '("AcadAnnotative")) ;; Lists registered app AcadAnnotative entries )

Updated code here

A version also for closed polylines. Minimally tested... centerPline_v2.LSP

Since we're all going off topic (thanks a lot Bigal ) , might as well join the band. Added the 'check before paste' lisp to my toolbar. Not sure if I'm ever gonna use it but that wasn't the point, was working on a way to make it a little more easier for myself to update the toolbars for my colleagues (the old last century toolbars , you oldies know what I mean) so lazy as I am , created a button for that too. It hasn't been field tested though so it may or may not work at all... New for me was the help part. Never used html in my life before and also read-write stream only used a couple of times (to create a few .bmp files for the toolbar by means of lisp , look for the Party button) So lets party yeah! euh ...the button I mean (oh just press the darn help button) Easy_Toolbar_Creator.lsp

You can try if this works better. No dbx in this version Start app , make selection , select drawing you want to paste in later. This drawing is shortly opened (not sure if it works if drawing is already open) List with blocknames is created and drawing is closed. Blocknames are compared and if duplicates are found message is displayed. You can choose 1- Stop , 2 - Rename the blocks in drawing you made the selection set (not the other drawing), or 3 - copy / paste as it is. Only thing left to do is select your basepoint (or replace 'pause' with "0,0" in the code) and selection set is placed on clipboard , ready to paste. ;;; check before paste - rlx 2025-10-22 (defun c:cbp ( / this-dwg ss other-dwg blocknames-in-selectionset blocknames-in-other-dwg duplicate-blocknames dbx-doc) (setq this-dwg (vla-get-ActiveDocument (vlax-get-acad-object))) (if (and (setq ss (ssget)) (setq other-dwg (getfiled "Drawing to check before you paste" "" "dwg" 0))) (progn (if (vl-consp (setq blocknames-in-selectionset (Get_SS_BlockNames ss))) (setq blocknames-in-selectionset (mapcar 'strcase blocknames-in-selectionset))) (if (vl-consp (setq blocknames-in-other-dwg (Get_EX_Blocknames other-dwg))) (setq blocknames-in-other-dwg (mapcar 'strcase blocknames-in-other-dwg))) (setq duplicate-blocknames (compare_block_names blocknames-in-selectionset blocknames-in-other-dwg)) (if (vl-consp duplicate-blocknames) (progn (dplm duplicate-blocknames "Duplicated block names : ") (setq inp (cfl (list "1 - I'm not gonna paste" "2 - Rename blocks before pasting" "3 - I'm gonna paste anyway"))) (cond ((or (void inp) (wcmatch inp "1*")) (alert "Copybase aborted")) ((wcmatch inp "2*")(foreach b duplicate-blocknames (rename_block_definition b)) (princ "\nBlocks are renamed - select your basepoint now") (command "_copybase" pause ss "")) ((wcmatch inp "3*") (princ "\nBlock names unchanged - select your basepoint now")(command "_copybase" pause ss "")) (t (princ"\nBite me...")) ) ) (progn (princ "\nNo duplicate block names found - select your basepoint")(command "_copybase" pause ss "")) ) ) ) (princ) ) ;;; get block names active doc - vanilla (defun _bl ( / b l ) (while (setq b (tblnext "BLOCK" (null b))) (if (zerop (boole 1 21 (cdr (assoc 70 b)))) (setq l (cons (cdr (assoc 2 b)) l)))) l) (defun Get_EX_Blocknames (other-dwg / fn l) (if (and (eq (type other-dwg) 'STR)(setq fn (findfile other-dwg)) (setq doc (vla-open (vla-get-documents (vlax-get-acad-object)) fn))) (progn (setq l (GetDocBlockNames doc))(vla-close doc)(vlax-release-object doc))) l) ;;; test (setq lst (GetDocBlockNames (vla-get-ActiveDocument (vlax-get-acad-object)))) (defun GetDocBlockNames ( d / b n l) (vlax-for b (vla-get-blocks d) (if (and (= :vlax-false (vla-get-isxref b)) (= :vlax-false (vla-get-islayout b)) (not (vl-string-search "*" (setq n (vla-get-name b)))))(setq l (cons n l)))) l) (defun create_unique_blockname ( $bn / i bn) (setq i 0)(while (tblsearch "block" (setq bn (strcat $bn "_" (itoa (setq i (1+ i))))))) bn) (defun rename_block_definition ( $bn / bc bn ) (setq bc (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))) (if (and (not (void $bn)) (tblsearch "block" $bn)) (vla-put-name (Collection-Member $bn bc)(setq bn (create_unique_blockname $bn)))) bn) (defun compare_block_names (a b / c) (and (vl-consp a) (vl-consp b) (foreach item a (if (member item b) (setq c (cons item c))))) c) (defun Get_SS_BlockNames ( ss / n l) (foreach o (ss->ol ss)(if (and (setq n (block-n o))(not (member n l)))(setq l (cons n l)))) l) (defun SS->OL (ss / i l)(setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) (defun void (x) (or (eq x nil)(and (listp x)(not (vl-consp x)))(and (eq 'STR (type x))(eq "" (vl-string-trim " \t\r\n" x))))) (defun block-n (o)(if (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference")) (if (vlax-property-available-p o 'EffectiveName) (vla-Get-EffectiveName o) (vla-Get-Name o)) nil)) (defun Collection-Member (m c / r) (if (vl-catch-all-error-p (setq r (vl-catch-all-apply 'vla-item (list c m)))) nil r)) ;;; 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)))) ;; 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))) edit : just had an idea , why not open the 'to be pasted' drawing after you made your selection. Also tried if it was a bad thing if both drawings were already open and yes , that's bad... but then I'm a bad bad dragon (it still opens but as read only) Because I use vla-activate at the end , all lisp stops (obviously) Once drawings is activated you can copypaste / ctrl-V yourself (I'm sure as hell not comming to do that for you ) You decide what make you happy... ;;; check before paste 2 : after selection open the 'to be pasted' drawing - rlx 2025-10-22 (defun c:cbp2 ( / acDoc *docs* ss dbDoc blocknames-in-selectionset blocknames-in-dbDoc duplicate-blocknames inp do-it) (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)) *docs* (vla-get-documents (vlax-get-acad-object))) (if (and (setq ss (ssget)) (setq dbDoc (getfiled "Drawing to check before you paste" "" "dwg" 0))) (progn (if (vl-consp (setq blocknames-in-selectionset (Get_SS_BlockNames ss))) (setq blocknames-in-selectionset (mapcar 'strcase blocknames-in-selectionset))) (if (vl-consp (setq blocknames-in-dbDoc (Get_EX_Blocknames dbDoc))) (setq blocknames-in-dbDoc (mapcar 'strcase blocknames-in-dbDoc))) (setq duplicate-blocknames (compare_block_names blocknames-in-selectionset blocknames-in-dbDoc)) (if (vl-consp duplicate-blocknames) (progn (dplm duplicate-blocknames "Duplicated block names : ") (setq inp (cfl (list "1 - I'm not gonna paste" "2 - Rename blocks before pasting" "3 - I'm gonna paste anyway"))) (cond ((or (void inp) (wcmatch inp "1*")) (alert "Copybase aborted")) ((wcmatch inp "2*")(foreach b duplicate-blocknames (rename_block_definition b)) (princ "\nBlocks are renamed - select your basepoint now") ;|(command "_copybase" pause ss "")|; (setq do-it t)) ((wcmatch inp "3*") (princ "\nBlock names unchanged - select your basepoint now") ;|(command "_copybase" pause ss "")|; (setq do-it t)) (t (princ"\nBite me...")) ) ) (progn (princ "\nNo duplicate block names found - select your basepoint") ;|(command "_copybase" pause ss "")|; (setq do-it t)) ) ) ) (if do-it (do_it)) ) (defun do_it ( / f d) (command "_copybase" pause ss "")(and (eq (type dbDoc) 'STR) (setq f (findfile dbDoc))(setq d (vla-open *docs* f)))(vla-activate d)) ;;; get block names active doc - vanilla (defun _bl ( / b l ) (while (setq b (tblnext "BLOCK" (null b))) (if (zerop (boole 1 21 (cdr (assoc 70 b)))) (setq l (cons (cdr (assoc 2 b)) l)))) l) (defun Get_EX_Blocknames (dbDoc / fn l) (if (and (eq (type dbDoc) 'STR)(setq fn (findfile dbDoc)) (setq doc (vla-open (vla-get-documents (vlax-get-acad-object)) fn))) (progn (setq l (GetDocBlockNames doc))(vla-close doc)(vlax-release-object doc))) l) ;;; test (setq lst (GetDocBlockNames (vla-get-ActiveDocument (vlax-get-acad-object)))) (defun GetDocBlockNames ( d / b n l) (vlax-for b (vla-get-blocks d) (if (and (= :vlax-false (vla-get-isxref b)) (= :vlax-false (vla-get-islayout b)) (not (vl-string-search "*" (setq n (vla-get-name b)))))(setq l (cons n l)))) l) (defun create_unique_blockname ( $bn / i bn) (setq i 0)(while (tblsearch "block" (setq bn (strcat $bn "_" (itoa (setq i (1+ i))))))) bn) (defun rename_block_definition ( $bn / bc bn ) (setq bc (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))) (if (and (not (void $bn)) (tblsearch "block" $bn)) (vla-put-name (Collection-Member $bn bc)(setq bn (create_unique_blockname $bn)))) bn) (defun compare_block_names (a b / c) (and (vl-consp a) (vl-consp b) (foreach item a (if (member item b) (setq c (cons item c))))) c) (defun Get_SS_BlockNames ( ss / n l) (foreach o (ss->ol ss)(if (and (setq n (block-n o))(not (member n l)))(setq l (cons n l)))) l) (defun SS->OL (ss / i l)(setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) (defun void (x) (or (eq x nil)(and (listp x)(not (vl-consp x)))(and (eq 'STR (type x))(eq "" (vl-string-trim " \t\r\n" x))))) (defun block-n (o)(if (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference")) (if (vlax-property-available-p o 'EffectiveName) (vla-Get-EffectiveName o) (vla-Get-Name o)) nil)) (defun Collection-Member (m c / r) (if (vl-catch-all-error-p (setq r (vl-catch-all-apply 'vla-item (list c m)))) nil r)) ;;; 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)))) ;; 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)))

For completeness, the key here is the "Repeat" option of the -INSERT command - though, I'm unsure in which version this relatively new keyword was introduced.

If you need more information, check the documentation on the CMDACTIVE system variable.

It won't - it will continue indefinitely until the user presses Esc to force it to exit.

Select both polylines find the polyline that has the most vertex Then process those vertex with vlax-curve-getClosestPointTo store the mid point of vertex and closest point in a list entmake new polyline with list points. Seems to work well tho will need to test if you have open or closed polylines. defaults to closed tho i don't think its quite the mid / avg path this code isn't quite right see later post. ;;----------------------------------------------------------------------------;; ;; CLOSE POLY AVERAGE, Finds the mid point avg between close polylines donut shape (defun c:CLOSEPOLYAVG (/ sel1 sel2 ent1 ent2 cnt1 cnt2 main other i ptv ptc mid pts) (defun c:CPA () (C:CLOSEPOLYAVG)) (defun midpt (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2) ) (setq sel1 (entsel "\nSelect First close Polyline: ")) (setq sel2 (entsel "\nSelect Second closed Polyline: ")) (if (and sel1 sel2) (progn (setq ent1 (vlax-ename->vla-object (car sel1)) ent2 (vlax-ename->vla-object (car sel2)) cnt1 (fix (vlax-curve-getEndParam ent1)) cnt2 (fix (vlax-curve-getEndParam ent2)) ) (if (> cnt1 cnt2) (setq main ent1 other ent2) (setq main ent2 other ent1) ) (setq pts '()) (setq i 0) (while (<= i (fix (vlax-curve-getEndParam main))) (setq ptv (vlax-curve-getPointAtParam main i)) (setq ptc (vlax-curve-getClosestPointTo other ptv)) (setq mid (midpt ptv ptc)) (setq pts (append pts (list mid))) (setq i (1+ i)) ) (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length pts)) '(70 . 1) ;; closed ) (mapcar '(lambda (p) (cons 10 p)) pts) ) ) (princ "\nNew midpoint polyline created.") ) (princ "\nSelection error.") ) (princ) )

attout and attin?

I checked: it works on Autocad... on GstarCAD it doesn't work. It doesn't matter, I use your previous file that reported the error but didn't allow renaming (CAPFD) thank you so much RLX for your effort!

I think I've achieved a workaround. I'm going to set a macro within excel that exports the data to a CSV every time the excel document is saved (overwriting the existing versions). I'm then going to read this using the standard IO functions available to me in LT. It's not the cleanest solution, but I believe it should work. If anyone has any advice regarding pitfalls etc. that I might encounter please feel free to enlighten me

@Danielm103 Thank you for this, it looks really good. The problem is that I'm building this for people that are exceptionally resistant to change, and really I need a standalone lisp that can just be launched from within autocad and handles everything. If there is any more complexity to it than that, then it simply wont even be considered for adoption @Steven P Thanks for the info, I'll take a look this evening once I've got my actual work out of the way for the day

well , downloaded your files on my homedragon and no errors on my side , maybe others can give it a go and see if they get an error?

Posting a drawing would help to be more clear with what your asking for. but maybe this is what your looking for. PAV

Depending on your version of CAD, you can use this: (defun c:test ( ) (command "_.-insert" "yourblockname" "_s" 1 "_r" 0 "_re" "_y") (while (= 1 (logand 1 (getvar 'cmdactive))) (command "\\")) (princ) )

If it is just a stand alone action, this will work but you have to escape out of it to cancel - you cannot have more to the routine, so stand alone only (while (= (command "-INSERT" GV-Block pause "" "" "0") nil) ) or this (while (setq pt1 (getpoint "Press LH Mouse to repeat, Enter / Space cancel")) (= (command "-insert" "circuitBreaker" pause 1 1 0) nil) )

Had a bit of time, so heres an animated version (defun c:cPoly (/ ent1 ent2 i j mPt len pt p1 ptlst grlst grlin) (vl-load-com) (if (and (setq ent1 (car (entsel "\nSelect First Polyline: "))) (wcmatch (cdr (assoc 0 (entget ent1))) "*POLYLINE")) (if (and (setq ent2 (car (entsel "\nSelect Second Polyline: "))) (wcmatch (cdr (assoc 0 (entget ent2))) "*POLYLINE")) (progn (setq i -1 len (/ (vla-get-Length (vlax-ename->vla-object ent1)) 100.) grlin '( )) (while (and (grread 't) (setq pt (vlax-curve-getPointatDist ent1 (* (setq i (1+ i)) len)))) (redraw) (setq p1 (vlax-curve-getClosestPointto ent2 pt t) ptlst (cons (setq mPt (polar pt (angle pt p1) (/ (distance pt p1) 2.))) ptlst) j -1 grlst nil) (repeat 500 (setq grlst (cons (polar mPt (* (setq j (1+ j)) (/ pi 250.)) (distance mPt p1)) grlst))) (setq grlin (append grlin (list (if grlin (last grlin) mPt) mPt))) (grvecs (append '(3) grlst (cdr grlst) (list (car grlst)))) (grvecs (append '(1) grlin))) (redraw) (setq ptlst (apply 'append (mapcar (function (lambda (x) (list (car x) (cadr x)))) ptlst))) (vla-AddLightWeightPolyline (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-VBDouble (cons 0 (1- (length ptlst)))) ptlst)))))) (princ)) Enjoy! Lee