Leaderboard

Even simpler: (defun c:DrawPLHoles (/ ss i ent rect-obj coords pts pt1 pt2 pt3 width height minSide offset v1 v2 v_sum v_len pt2_in ) (setq ss (ssget '((0 . "LWPOLYLINE")))) (if ss (progn (setq i 0) (repeat (sslength ss) (setq ent (ssname ss i) pts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (setq lst (entget ent)))) pts (if (member (cdr (assoc 70 lst)) '(1 129)) (append pts (list (car pts))) pts) xmin (apply 'min (mapcar 'car pts)) ymin (apply 'min (mapcar 'cadr pts)) xmax (apply 'max (mapcar 'car pts)) ymax (apply 'max (mapcar 'cadr pts)) lc (/ (min (- xmax xmin) (- ymax ymin)) 4.0) pt (list (+ xmin lc) (- ymax lc)) ) (command "_PLINE" (list xmin ymin) pt (list xmax ymax) "") (setq i (1+ i)) ) ) ) (princ) )

Your code can be as simple as this... (defun c:DrawPLHoles (/ ss i ent rect-obj coords pts pt1 pt2 pt3 width height minSide offset v1 v2 v_sum v_len pt2_in xmin ymin xmax ymax lc pt ) (setq ss (ssget '((0 . "LWPOLYLINE")))) (if ss (progn (setq i 0) (repeat (sslength ss) (setq ent (ssname ss i)) (setq rect-obj (vlax-ename->vla-object ent)) (setq coords (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates rect-obj)) ) ) ;; get 4 vertices (setq pts (list (list (nth 0 coords) (nth 1 coords)) (list (nth 2 coords) (nth 3 coords)) (list (nth 4 coords) (nth 5 coords)) (list (nth 6 coords) (nth 7 coords)) ) xmin (apply 'min (mapcar 'car pts)) ymin (apply 'min (mapcar 'cadr pts)) xmax (apply 'max (mapcar 'car pts)) ymax (apply 'max (mapcar 'cadr pts)) lc (/ (min (- xmax xmin) (- ymax ymin)) 4.0) pt (list (+ xmin lc) (- ymax lc)) ) (command "_PLINE" (list xmin ymin) pt (list xmax ymax) "") (setq i (1+ i)) ) ) ) (princ) )

I run Bricscad v25 pro and all you need to do is appload or drag and drop etc the goto.lsp then type goto works for me the DCL is hard coded in the code. I know what it might be I updated the GOTO.lsp this is latest version, prior version used "multi getvals.lsp" for the dcl. Goto-layout.lsp

Ok not copy but goto, as name implies when you have lots of layouts example a dwg with 88 layouts so Goto 1 look up index then goto 23. goto 99 goes to last layout. A Goto is not included in CAD but is in a lot of other software, so wrote one years ago. Goto-layout.lsp

@GLAVCVS nice code re front end could a DCl that asks how many chords then pops a child dcl or new dcl with edit boxes to enter the chord values. This image is dummied up. Would use Multi getval.lsp for the multiple answers as you just make a list and the dcl is auto generated. ; the input box size can be bigger just change the two values tetsed with 145 145 and worked ok. (if (not AH:getvalsm)(load "Multi Getvals.lsp")) (setq ans1 (AH:getvalsm (list "How many chords " "chords" 5 4 "3" ))) (setq ans2 (AH:getvalsm (list "Enter values " "chord1" 5 4 "" "chord2" 5 4 "" "chord3" 5 4 ""))) ; (setq ans2 (AH:getvalsm lst))

Ok you need a couple of defuns then its easy. 1st defun is it clockwise or anticlockwise. Set to CW. 2nd rotate the rectang points till lower left is the 1st point The draw pline then is easy as using a polar with angle pt2 pt4. ; Checking if pline is CW or CCW and set to CCW ; Orignal idea by Kent Cooper, 1 August 2018 Offsetinorout.lsp ; By Alan H July 2020 (defun AH:chkcwccw (ent / objnew area1 area2 obj minpoint maxpoint) (setq obj (vlax-ename->vla-object ent)) (vla-GetBoundingBox obj 'minpoint 'maxpoint) (setq pointmin (vlax-safearray->list minpoint)) (setq pointmax (vlax-safearray->list maxpoint)) (setq dist (/ (distance pointmin pointmax) 20.0)) (vla-offset obj dist) (setq objnew (vlax-ename->vla-object (entlast))) (setq area1 (vlax-get objnew 'Area)) (vla-delete objnew) (vla-offset obj (- dist)) (setq objnew (vlax-ename->vla-object (entlast))) (setq area2 (vlax-get objnew 'Area)) (vla-delete objnew) (if (> area1 area2) (progn ;(command "reverse" ent "") (alert "needs reverse ") (setq y (+ y 1)) ) ) ) (defun rotate-rectang (lst / corner) (setq corner ; find left most corner with a sort (car (vl-sort lst (function (lambda (a b) (if (equal (car a) (car b) 1e-4) (< (cadr a) (cadr b)) (< (car a) (car b)) ) ) ) ) ) ) (while (/= (car lst) corner) ; rotate until corner is the first item (setq lst (append (cdr lst) (list (car lst)))) ) lst ; return lst )

Possibly the only way around having a tolerance on the Y would be to use some form of selection order, but that removes the automation. The other way may be to say round the Y value before saving in the lst list. if say objects have a Y of 20.25 & 19.9 then they could be rounded to 20. There is rounding code out there. Have a go. https://www.lee-mac.com/round.html

Okay, sorry about that. If you get stuck, here’s a lisp callable function (copyLayout "A-4" "A-44") from pyrx import Rx, Ge, Gi, Db, Ap, Ed import traceback @Ap.LispFunction() def copyLayout(args): try: if len(args) != 2: return None t1, fromLayout = args[0] t2, toLayout = args[1] db = Db.curDb() lm = Db.LayoutManager() lm.copyLayout(fromLayout, toLayout, db) return True except Exception as err: traceback.print_exception(err) return None

Thank you so much @Jerry Fiedler. Said by you, those words are an honor for me. I think we still need to find the "orthodox" way to do the calculations. For example:

@GLAVCVS I tried your program and it is very nice. Yesterday I was thinking of writing a random chord length routine but you seem to have a good solution, so now I will just study your code to see what I can learn.

@Danielm103 Hi!! Despite that post where you helped me with that table with images, I'm not even close to being able to implement the 'ctab conversion in Python. Not to mention that the 'ctab section is just a small part of a larger lisp, which I certainly can't rewrite in Python... thanks, aridzv.

Aren't you setup with Python? use the LayoutManager from pyrx import Rx, Ge, Gi, Db, Ap, Ed, command @command def doit(): db = Db.curDb() fromTab = Ed.Core.getVar('ctab') ps, toTab = Ed.Editor.getString(1, "Enter a tabname: ") if ps == Ed.PromptStatus.eOk: lm = Db.LayoutManager() lm.copyLayout(fromTab, toTab, db)

Continued... These rename... ;;; Copy layout and rename (focus on new layout) ;;; ;;; https://www.cadtutor.net/forum/topic/97834-how-to-copy-a-layout-using-vla-object/#findComment-670382 ;;; ;;; SLW210 (a.k.a. Steve Wilson ;;; (defun c:CRL_VLA ( / acadObj doc layouts oldLayout newLayoutName newLayout oldLayoutObj psOld psNew ss) (vl-load-com) (setq acadObj (vlax-get-acad-object)) (setq doc (vla-get-ActiveDocument acadObj)) (setq layouts (vla-get-Layouts doc)) (setq oldLayout (getvar "CTAB")) (if (wcmatch oldLayout "Model") (princ "\nCannot copy the Model tab.") (progn (setq newLayoutName (getstring "\nEnter the full name for the new layout (e.g., 'A-44_rev1'): ")) ;; Create and copy layout settings (setq newLayout (vla-Add layouts newLayoutName)) (setq oldLayoutObj (vla-Item layouts oldLayout)) (vla-CopyFrom newLayout oldLayoutObj) ;; Get block records for old and new layout (setq psOld (vla-get-Block oldLayoutObj)) (setq psNew (vla-get-Block newLayout)) ;; Copy entities from old layout to new layout (vlax-for ent psOld (vla-CopyObjects doc (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbObject '(0 . 0)) (list ent))) psNew ) ) ;; Set the new layout as active (vla-put-ActiveLayout doc newLayout) (princ (strcat "\nLayout copied and renamed to: " newLayoutName)) ) ) (princ) ) ;;; Copy layout and rename (focus remains on old layout) ;;; ;;; https://www.cadtutor.net/forum/topic/97834-how-to-copy-a-layout-using-vla-object/#findComment-670382 ;;; ;;; SLW210 (a.k.a. Steve Wilson ;;; (defun c:CRL_VLA_1 ( / acadObj doc layouts oldLayout newLayoutName newLayout oldLayoutObj psOld psNew ss) (vl-load-com) (setq acadObj (vlax-get-acad-object)) (setq doc (vla-get-ActiveDocument acadObj)) (setq layouts (vla-get-Layouts doc)) (setq oldLayout (getvar "CTAB")) (if (wcmatch oldLayout "Model") (princ "\nCannot copy the Model tab.") (progn (setq newLayoutName (getstring "\nEnter the full name for the new layout (e.g., 'A-44_rev1'): ")) ;; Create and copy layout settings (setq newLayout (vla-Add layouts newLayoutName)) (setq oldLayoutObj (vla-Item layouts oldLayout)) (vla-CopyFrom newLayout oldLayoutObj) ;; Get block records for old and new layout (paper space) (setq psOld (vla-get-Block oldLayoutObj)) (setq psNew (vla-get-Block newLayout)) ;; Copy entities from old layout to new layout (vlax-for ent psOld (vla-CopyObjects doc (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbObject '(0 . 0)) (list ent))) psNew ) ) (princ (strcat "\nLayout copied and renamed to: " newLayoutName)) ) ) (princ) )

Just curious, you posted a pretty much empty sample drawing, I have some different ones you can try. These worked on your drawing with AutoCAD 2024. These add a suffix... ;;; Copy layout and add suffix (focus on new layout) ;;; ;;; https://www.cadtutor.net/forum/topic/97834-how-to-copy-a-layout-using-vla-object/#findComment-670382 ;;; ;;; SLW210 (a.k.a. Steve Wilson ;;; (defun c:CLAS_VLA ( / acadObj doc layouts oldLayout newSuffix newLayoutName newLayout oldLayoutObj psOld psNew ss) (vl-load-com) (setq acadObj (vlax-get-acad-object)) (setq doc (vla-get-ActiveDocument acadObj)) (setq layouts (vla-get-Layouts doc)) (setq oldLayout (getvar "CTAB")) (if (wcmatch oldLayout "Model") (princ "\nCannot copy the Model tab.") (progn (setq newSuffix (getstring "\nEnter text to add to layout name (e.g., '_rev1'): ")) (setq newLayoutName (strcat oldLayout newSuffix)) ;; Create and copy layout settings (setq newLayout (vla-Add layouts newLayoutName)) (setq oldLayoutObj (vla-Item layouts oldLayout)) (vla-CopyFrom newLayout oldLayoutObj) ;; Get block records for old and new layout (paper space) (setq psOld (vla-get-Block oldLayoutObj)) (setq psNew (vla-get-Block newLayout)) ;; Copy entities from old layout to new layout (vlax-for ent psOld (vla-CopyObjects doc (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbObject '(0 . 0)) (list ent))) psNew ) ) ;; Set the new layout as active (vla-put-ActiveLayout doc newLayout) (princ (strcat "\nLayout copied and renamed to: " newLayoutName)) ) ) (princ) ) ;;; Copy layout and add suffix (focus remains on old layout) ;;; ;;; https://www.cadtutor.net/forum/topic/97834-how-to-copy-a-layout-using-vla-object/#findComment-670382 ;;; ;;; SLW210 (a.k.a. Steve Wilson ;;; (defun c:CRL_VLA_1 ( / acadObj doc layouts oldLayout newSuffix newLayoutName newLayout oldLayoutObj psOld psNew ss) (vl-load-com) (setq acadObj (vlax-get-acad-object)) (setq doc (vla-get-ActiveDocument acadObj)) (setq layouts (vla-get-Layouts doc)) (setq oldLayout (getvar "CTAB")) (if (wcmatch oldLayout "Model") (princ "\nCannot copy the Model tab.") (progn (setq newSuffix (getstring "\nEnter text to add to layout name (e.g., '_rev1'): ")) (setq newLayoutName (strcat oldLayout newSuffix)) ;; Create and copy layout settings (setq newLayout (vla-Add layouts newLayoutName)) (setq oldLayoutObj (vla-Item layouts oldLayout)) (vla-CopyFrom newLayout oldLayoutObj) ;; Get block records for old and new layout (paper space) (setq psOld (vla-get-Block oldLayoutObj)) (setq psNew (vla-get-Block newLayout)) ;; Copy entities from old layout to new layout (vlax-for ent psOld (vla-CopyObjects doc (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbObject '(0 . 0)) (list ent))) psNew ) ) (princ (strcat "\nLayout copied and renamed to: " newLayoutName)) ) ) (princ) )

Hi I created the main function, but I've been busy for a couple of days and didn't have time to prepare a small interface with a dialog box. The idea also struck me to write some code to add the option to obtain the chords of the complementary angle to the command (as in the following image) As if that weren't enough, I also came up with a possible solution using a system of as many equations as there are chords + 1 to calculate. Too many ideas for so little time. So, for now, I'll leave a version of <<Extravagant Chords V.1>> that can be run from the command line. The tool will work on 'LINE's and 'LWPOLYLINE's and should be used, in the latter case, by selecting the end segments of the selected polyline or polylines so that the ends are correctly joined with the calculated chords. The number of chords to be entered is unlimited. PS: A tool like this, contrary to what @Eldon thinks, if it becomes an option available to a designer or architect, I think it could be used frequently over time. ; Made for https://www.cadtutor.net/forum/topic/97799 14/05/2025 ; ;******** << E x t r a v a g a n t C h o r d s V.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:ExtravagantChords (/ para in sc lCs op errores error0) (defun errores (mens) (setq *error* error0) (prin1) ) (defun obtPtsCuerdas (lCds op / p1 p2 p3 p4 radio dameAng dameASubt d1 d2 v f ab T1 T2 pR rf1 rf2 ct r ld pa b x p o le1 le2 s1 s2 px1 px2 les) (defun radio (aT lc / Rmin Rmax R1/2 tl ta dameAngulos); donde 'aT' es el angulo del arco a 'acordar' y 'lc' la lista de las longitudes de las cuerdas a aplicar (defun dameAngulos (R / a); obtenemos suma total de los arcos subtendidos (apply '+ (mapcar '(lambda (L) (* 2 (atan (setq a (/ L (* 2.0 R))) (sqrt (- 1.0 (* a a)))))) lc)) ) (setq Rmin (/ (apply 'max lc) 2.0) ; radio mínimo posible Rmax 1e6 ; radio máximo arbitrario tl 1e-12 ; tolerancia ) (while (> (- Rmax Rmin) tl); Búsqueda por bisección (if (> (dameAngulos (setq R1/2 (/ (+ Rmin Rmax) 2.0))) aT) (setq Rmin R1/2) ; el radio es demasiado pequeño (setq Rmax R1/2) ; el radio es demasiado grande ) ) (/ (+ Rmin Rmax) 2.0); Devolvemos el promedio del rango de radios posibles encontrados ) (defun actEs (/ l r so ls l?) (foreach l (list (list px1 (car le1) d1) (list px2 (car le2) d2)) (setq r (equal (distance (car l) (cdr (assoc 10 (setq ls (entget (cadr l)))))) 0. 1e-6) l? (= (cdr (assoc 0 ls)) "LINE") so (if (equal (caddr l) (angle v (car o)) 1e-6) (car o) (last o)) ) (entmod (subst (cons (if (and l? (not r)) 11 10) so) (assoc (if (and l? (not r)) 11 10) (if r ls (reverse ls))) ls)) ) ) (defun dameAng (p1 p2 p3 p4 / f) ; ESTA FUNCION SIEMPRE DEVUELVE EL ANGULO INFERIOR A PI (if (> (setq f (abs (- (angle p1 p2) (angle p3 p4)))) pi) (- (* 2 pi) f) f) ) (defun dameASubt (l r / a) ; devuelve el arco subtendido para la cuerda de longitud l sobre el arco de radio r (* 2.0 (atan (setq a (/ l (* 2.0 r))) (sqrt (- 1.0 (* a a))))) ) (defun os (le / x pk tm f d p i s a b tam) (setq tam (* (getvar "pickbox") (/ (GETVAR "VIEWSIZE") (CADR (GETVAR "SCREENSIZE"))))) (while (and (if x x (setq x (entget (car le)) pk (if (= (cdr (assoc 0 x)) "LWPOLYLINE") (cadr le)) b t)) (setq f (cdr (assoc (if pk 10 11) (setq x (cdr (member (setq p (assoc 10 x)) x)))))) (if pk (not (inters f (cdr p) (polar pk (+ (setq a (angle f (cdr p))) 1.5708) tam) (polar pk (- a 1.5708) tam)))) ) ) (list (cdr p) f) ) (if (setq s1 (os (setq le1 (entsel "\nSelect FIRST segment...")))) (if (setq s2 (os (setq le2 (entsel "\nSelect SECOND segment...")))) (if (setq v (inters (setq p1 (car s1)) (setq p2 (cadr s1)) (setq p3 (car s2)) (setq p4 (cadr s2)) nil));(inters p1 p2 p3 p4 nil)) (setq d1 (if (< (distance V p1) (distance V p2)) (angle (setq px1 p1) p2) (angle (setq px1 p2) p1)) ;d1 es la direccion del primer segmento d2 (if (< (distance V p3) (distance V p4)) (angle (setq px2 p3) p4) (angle (setq px2 p4) p3)) ;d2 es la direccion del segundo segmento f (if (> (setq f (abs (- d1 d2))) pi) (- (* 2 pi) f) f) ;aseguramos angulo minimo. f es el angulo incluido entre las 2 lineas ab (+ ((if (> (abs (- d1 d2)) PI) max min) d1 d2) (/ f 2.0)) ;angulo bisectriz T1 (inters V (polar V d1 10000) (setq pR (polar V ab 100)) (polar pR (+ d1 (/ pi 2)) 10000) nil) ;punto tangente 1 (temporal para cálculos previos) T2 (inters V (polar V d2 10000) pR (polar pR (+ d2 (/ pi 2.0)) 10000) nil) ;punto tangente 2 (temporal para cálculos previos) ct (inters T1 (polar T1 (+ d1 (/ pi 2)) 100) v (polar v ab 100) nil) ; calculamos centro (temporal para cálculos previos) r (radio (dameAng ct T1 ct T2) lCds) ;radio necesario para encajar las cuerdas ld (/ r (/ (sin (/ f 2.0)) (cos (/ f 2.0)))) ; calculamos el cateto largo hasta el punto tangente del arco ct (inters (setq pa (polar v d1 ld)) (polar pa (+ d1 (/ pi 2)) 100) v (polar v ab 100) nil) ; calculamos el centro del arco rf1 (angle pR T1) rf2 (angle pR T2) b ((if (> (abs (- rf1 rf2)) PI) max min) rf1 rf2) ; angulo base para obtener puntos de cuerdas por polares x (foreach c lCds (setq o (cons (polar ct (if (> (setq g (+ b (dameASubt c r)) ) 6.2831853) (- g 6.2831853) g) r) (if o o (list (polar ct b r))) ) b g ) ) x (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(8 . "0") '(100 . "AcDbPolyline") (cons 90 (length o))) (mapcar '(lambda(x) (cons 10 x)) o))) x (if op (actEs)) ) ) ) ) (princ) ) (setq error0 *error* *error* errores ) (while (not para) (setq sc (getreal (strcat "\rIndicate length CHORD number " (itoa (setq in (if in (1+ in) 1))) " (CounterClockWise) (or ENTER to finish): "))) (if sc (setq lCs (append lcs (list sc))) (setq para T) ) ) (while (not (member (setq op (strcase (getstring "\rDo you want to snap lines/lwpolylines to calculated chords? <YES>/NO: "))) '("" "Y" "N"))) (princ "\n*** Invalid option. Try again (ENTER, Y or N)... ***") ) (obtPtsCuerdas lCs (if (= op "N") nil T)) (princ) ) I apologize for not translating the comments.

Here is my solution to the multi-chord length problem. We have three unknown subtended angles and three equations. The first equation sums the individual angles: 2*a1 + 2*a2 + a3 = A/2. The angles a1, a2 and a3 are half the subtended arc associated with chord 1, 2 and 3 and A/2 is half the overall angle. The chord length is: Ci = 2*rad*Sin(ai) or the half-chord ci = rad*Sin(ai). Solving for rad = ci / Sin(ai). This is true for each chord since there is only one radius. Therefore c1 / Sin(a1) = c2 / Sin(a2)= c3 / Sin(a3). Taking the first two we get: Sin(a2) = c2*Sin(a1) / c1. This gives us our second equation: a2 = arcsine( c2*Sin(a1) / c1). Our third equation: a3 = arcsine( c3*Sin(a1) / c1). The code solves the three nonlinear equations for the three unknowns by incrementing angle a1 by a very small value and calculating a2 and a3 until equation 1 is more or less zero. The code uses 2*a1 + 2*a2 + a3 - A/2 --> 0. Starting with a small a1 this equation is negative so the solution is when the equation flips to positive. I found that stepping a1 by 0.0000005 provided good results. It takes a second or two to solve on my PC but the value can be adjusted for either more accuracy or faster time. An added feature of this version allows creating either 2, 3, 4 or 5 chords by inputting zero length for chords 2 or 3 or both. C1 must always have a length. Refer to the comments at the top of the lisp code. This code has no error checking. However, if the calculated radius is too large for the selected lines the "fillet" command that draws the arc will throw an error. I know of no way to correct for this since the routine simply creates a multi-faceted "fillet". If you can't draw a radius fillet then you cannot draw a multi-faceted fillet either. You will have to revisit your geometry. I think it works but please let me know if you have problems. ; Routine to add chords of different lengths on an arc tangent to two intersecting lines. ; Routine creates two to five chords of varying lengths symmetrically placed. ; ; Five chords (input three chord lengths): ; Chords 1 - 2 - 3 - 2 - 1 from start to end of arc. ; ; Four chords (input chord 3 length = 0.0): ; Chords 1 - 2 - 2 - 1 from start to end of arc. ; ; Three chords (input chord 2 length = 0.0): ; Chords 1 - 3 - 1 from start to end of arc. ; ; Two chords (input chord 2 and 3 length = 0.0) ; Chords 1 - 1 from start to end of arc. ; ; Routine uses global variables to store the chord lengths. ; ; Reference: ; https://www.cadtutor.net/forum/topic/97799-get-chords-of-two-or-three-different-lengths-on-the-same-arc/ ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Written: Jerry Fiedler - May 2025 ; LeeMac - asin and entmake code. ; Reinaldo Togores - Prompt for input with default values subroutine. ;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ (defun c:multichord ( / ent1 ent2 obj1 obj2 p1 p2 p3 p4 apex rad A X C1 C2 C3 end1 end2 arc len ans arcnm pS pE nodes j K1 K2 K3 done arc1 arc2 arc3 lenlst a1 a2 a3) ; Recall stored variables. ; If global variables are undefined set to zero. First time command called. (or *multichordC1* (setq *multichordC1* 0)) (or *multichordC2* (setq *multichordC2* 0.0)) (or *multichordC3* (setq *multichordC3* 0.0)) ; Accept stored values or enter new values. (initget 6) ; No negative values or zero. (setq *multichordC1* (default-value 'getreal "\nEnter length of chord ONE: " *multichordC1*)) (initget 4) ; No negative. (setq *multichordC2* (default-value 'getreal "\nEnter length of chord TWO: " *multichordC2*)) (initget 4) ; No negative. (setq *multichordC3* (default-value 'getreal "\nEnter length of chord THREE: " *multichordC3*)) (setq C1 *multichordC1*) (setq C2 *multichordC2*) (setq C3 *multichordC3*) ; Select lines. (setq ent1 (car (entsel "\nPick Line 1 "))) (setq ent2 (car (entsel "\nPick Line 2 "))) ; Get end points of selected lines. (setq obj1 (vlax-ename->vla-object ent1)) (setq obj2 (vlax-ename->vla-object ent2)) (setq p1 (vlax-get obj1 'startpoint)) (setq p2 (vlax-get obj1 'endpoint)) (setq p3 (vlax-get obj2 'startpoint)) (setq p4 (vlax-get obj2 'endpoint)) ; Calculate the intersection point Line 1 and Line 2. (setq apex (inters p1 p2 p3 p4 nil)) ; Calculate angle A between two lines. (if (equal apex p1 0.01)(setq end1 p2)(setq end1 p1)) (if (equal apex p3 0.01)(setq end2 p4)(setq end2 p3)) (setq X (CALang3P apex end1 end2)) (if (> X 180) (setq X (- 360 A))) (setq X (* pi (/ X 180.0))) (setq A (- pi X)) ; Solve for the three unknown half-angles subtended by each chord, a1, a2 and a3. ; Constants. (setq K1 (/ A 2)) (setq K2 (/ C2 C1)) (setq K3 (/ C3 C1)) ; Step through the three equations using a1 as the index. (setq done t) (setq a1 0.0175) (while done (setq a1 (+ a1 0.0000005)) (if (> a1 1.57) (progn (prompt "\nNo Solution")(setq done nil))) (setq a2 (asin (* (sin a1) K2))) (setq a3 (asin (* (sin a1) K3))) (if (> (+ (* 2 a1) (* 2 a2) a3 (- K1)) 0.0) (setq done nil)) ) (setq rad (/ (/ C1 2) (sin a1))) ; Create arc. (setvar 'filletrad rad) (command "fillet" ent1 ent2) (setq arcnm (entlast)) ; (command "chprop" arcnm "" "_LA" "P" "") (setq arc (vlax-ename->vla-object arcnm)) ; Establish nodes for chords. (setq pS (vlax-get arc 'startpoint)) (setq pE (vlax-get arc 'endpoint)) (setq arc1 (* 2 rad a1) arc2 (* 2 rad a2) arc3 (* 2 rad a3) ) (setq lenlst (list arc1 arc2 arc3 arc2)) (setq j 0) (setq len 0) (repeat 4 (setq len (+ len (nth j lenlst))) (setq nodes (cons (vlax-curve-getpointatdist arc len) nodes)) (setq j (1+ j)) ) (setq nodes (cons pE nodes)) (setq nodes (append nodes (list pS))) ; Create chord pline from list of nodes. ; Entmake code by Lee Mac (McDonnell) Febrary 2010 ; https://www.cadtutor.net/forum/topic/18257-entmake-functions/?tab=comments#comment-149347 (entmake (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length nodes))) (mapcar (function (lambda (p) (cons 10 p))) nodes)) ) ; Delete arc? (initget "YES NO") (setq ans "NO") (setq ans (cond ((getkword "\nSHOW ARC? [YES/NO] <YES>: ")) ("YES"))) (if (= ans "NO") (entdel arcnm)) ; Extend lines to apex? (initget "YES NO") (setq ans "NO") (setq ans (cond ((getkword "\nEXTEND LINES TO APEX? [YES/NO] <YES>: ")) ("YES"))) (if (= ans "YES") (progn (command "pline" pS apex pE "") ; (command "chprop" (entlast) "" "_LA" "P" "") ) ) (princ) ) ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; +++++++++++++++ SUBROUTINES +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Prompt for input with default values. ; Source: "AutoCAD Expert's Visual LISP" by Reinaldo N. Togores - 2012 ; Listing 7.1 in source book. ; Arguments: ; func -> An AutoCAD get... function preceded with a ' (NOT for getstring) ; message -> Prompt requesting input. ; value -> Defalut value which is used if <Enter> is pressed at prompt. (defun default-value (func message value / tmp) (if (setq tmp (apply func (list (strcat message "<" (vl-princ-to-string value) ">: " ) ) ) ) tmp value ) ) ; Two routines to determine the angle between lines: ; CALang2L -> Arguments are line entity names. (CALang2L ent1 ent2). ; CALang3P -> Arguments are three points. (CALang3P apex ptA ptB). ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; +++++++++++++++ Routine CALang2L ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Routine to be called by a lisp program to determine angle between two lines. ; The lines do not have to extend to their intersection point and may cross. ; The resulting angle is measured in the plane established by the two lines. ; The angle is always less than 180 degrees. ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Written: Jerry Fiedler - Apr 2025 ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Example: ; (CALang2L ent1 ent2) ; Arguments: ; Line 1 and Line 2 entity names. They must be lines, (0 . "LINE") and must not be collinear. ; Returns: ; Angle between Line 1 and Line2 expressed in degrees. Returns nil upon error. ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ (defun CALang2L (Line1 Line2 / p1 p2 p3 p4 apex alpha endL1 endL2 fuzz obj1 obj2 chk msg) ; Set a tolerance for the "equal" function. (setq fuzz 0.01) ; Convert to vla objects. (setq obj1 (vlax-ename->vla-object Line1)) (setq obj2 (vlax-ename->vla-object Line2)) ; Verify arguments are LINES. (setq chk 0) (if (= (vlax-get obj1 'ObjectName) "AcDbLine") (setq chk 1)) (if (= (vlax-get obj2 'ObjectName) "AcDbLine") (setq chk (+ 1 chk))) ; Get end points of both lines. (if (= chk 2) (progn (setq p1 (vlax-get obj1 'startpoint)) (setq p2 (vlax-get obj1 'endpoint)) (setq p3 (vlax-get obj2 'startpoint)) (setq p4 (vlax-get obj2 'endpoint)) ) ) ; Intersection of the two lines and angle calculations. (cond ((< chk 2) (setq msg (strcat "\nArguments provided the CALang function" "\nare not LINEs." "\nError returns nil.\n")) (prompt msg) (setq alpha nil) ) ((setq apex (inters p1 p2 p3 p4 nil)) (if (equal apex p1 fuzz)(setq endL1 p2) (setq endL1 p1)) (if (equal apex p3 fuzz)(setq endL2 p4) (setq endL2 p3)) ; Calculate angle between the selected lines. (setq alpha (CALang3P apex endL1 endL2)) ) (t (setq msg (strcat "\nLines do not intersect or" "\nare collinear." "\nError returns nil.\n")) (prompt msg) (setq alpha nil) ) ) alpha ) ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; +++++++++++++++ Routine CALang3P ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Routine to be called by a lisp program to determine angle between two implied lines defined by ; Line 1 from apex to point A and Line 2 from apex to point B. ; The resulting angle is measured in the plane established by the two implied lines. ; The angle is always less than 180 degrees. ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Concept: lrm @ Cadtutor Forum - Apr 2022 ; https://www.cadtutor.net/forum/topic/74922-angle-between-two-3d-points/ ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Modified: Jerry Fiedler - Apr 2025 ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; Example: ; (CALang3P pt1 pt2 pt3) ; Arguments: ; Three points where pt1 is the common apex of the implied lines and pt2 pt3 are the far ends. ; Returns: ; Angle between implied lines expressed in degrees. ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ (defun CALang3P (p1 p2 p3 / v1 v2 angrad @acos dot) ; *********************** SUBROUTINES ***************************************** ; ++++++++++++++ Function arc cos of an angle +++++++++++++++++++++++++++++++++++++++++++++++++++++ (defun @acos (cosine / sine) (cond ((zerop cosine)(* pi 0.5)) ((<= cosine -1.0) pi) ((>= cosine 1.0) 0.0) (t (atan (/ (sqrt (- 1.0 (expt cosine 2))) cosine))) ) ) ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; ++++++++++++++ Function for dot product of vectors a and b ++++++++++++++++++++++++++++++++++++++ (defun dot (a b / dd) (setq dd (mapcar '* a b)) (setq dd (+ (nth 0 dd) (nth 1 dd) (nth 2 dd))) ) ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; ++++++++++++++ Calculate unit vector ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ;; Unit Vector - Lee Mac (McDonnell) www.lee-mac.com ;; Args: v - vector in R^2 or R^3 (defun vx1 (v) ((lambda (n) (if (equal 0.0 n 1e-10) nil (mapcar '/ v (list n n n)))) (distance '(0.0 0.0 0.0) v) ) ) ; ++++++++++++++++++++ END SUBROUTINES ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; ++++++++++++++++++++ Main Routine +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ (setq v1 (vx1 (mapcar '- p2 p1))) (setq v2 (vx1 (mapcar '- p3 p1))) (setq angrad (@acos (dot v1 v2))) (if (< angrad 0.0) (setq angrad (+ pi angrad))) (/ (* angrad 180.0) pi) ) ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; ArcSine - Lee Mac https://www.lee-mac.com/mathematicalfunctions.html ; Args: -1 <= x <= 1 (defun asin ( x ) (if (<= -1.0 x 1.0) (atan x (sqrt (- 1.0 (* x x)))) ) ) (princ) MultiChord.lsp