Leaderboard

OK, here is one more try at this. Make a selection of all the lines you want whether they form a part of an arc or not. It -should- loop through it all and convert any it considers to be arcs into arcs. The calculation works matching the origin of a circle on formed on points of adjacent lines. If the origins are out by too much then they won't make an arc. Adjacent lines are found from an area round the end of the last one, however if there are very short lines this currently makes an error, and similarly a small gap between adjacent lines also has an error (I think I know the fix for these), But in a nice drawing this works well. In the example drawings above some of the more complex shapes have very short lines (like almost zero length) and very small gaps - I've put a small function in there to choose an adjacent line which fixes a couple of these but if not it zooms to the problem area - you'll see what I mean. Works better than what I had before Command: Lines2Arc ;;Errors on very short gaps ;;Check fuzz factors for small lines ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun LM:ss-union ( lst / out ss i a b) (setq lst (vl-sort lst '(lambda ( a b ) (> (sslength a) (sslength b)))) ) (setq out (car lst) ) (foreach ss (cdr lst) (repeat (setq i (sslength ss)) (ssadd (ssname ss (setq i (1- i))) out) ) ) out ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun linelength ( AnEnt Fuzz / Result Pt1 Pt2) (setq Pt1 (cdr (assoc 10 (entget AnEnt)))) (setq Pt2 (cdr (assoc 11 (entget AnEnt)))) (setq Result (distance Pt1 Pt2)) (if (< Result Fuzz)(setq Result 0)) Result ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun onlyunique ( MyList / ReturnList n ) (setq ReturnList (list)) ; blank list for result (foreach n MyList ; loop through supplied list (if ( = (member n (cdr (member n MyList))) nil) ; if list item occurs only once (setq ReturnList (append ReturnList (list n))) ; add to list ) ) ; end foreach ReturnList ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun uniquepoints ( MySS / MyList acount MyEnt) (princ "Select Lines") (setq MyList (list)) ; Blank list for line coordinates (setq acount 0) (while (< acount (sslength MySS)) ; loop each line (setq MyEnt (entget (ssname MySS acount))) (setq MyList (append MyList (list (cdr (assoc 10 MyEnt))))) ; add end A to list (setq MyList (append MyList (list (cdr (assoc 11 MyEnt))))) ; add end B to list (setq acount (+ acount 1)) ) (list (onlyunique MyList) MyList) ; list: Unique Items, All Items ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun 3parc ( pt1 pt2 pt3 / ocs lst ) ; Lee Mac (if (setq ocs (trans '(0 0 1) 1 0 t)) (if (setq lst (LM:3pcircle pt1 pt2 pt3)) (progn (if (minusp (sin (- (angle pt1 pt3) (angle pt1 pt2)))) (mapcar 'set '(pt1 pt3) (list pt3 pt1)) ) (entmakex (list '(000 . "ARC") (cons 010 (trans (car lst) 1 ocs)) (cons 040 (cadr lst)) (cons 050 (angle (trans (car lst) 1 ocs) (trans pt1 1 ocs))) (cons 051 (angle (trans (car lst) 1 ocs) (trans pt3 1 ocs))) (cons 210 ocs) ) ) ) (princ "\nPoints are collinear.") ) ) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun BndBx ( EntName AnArea / mn mx) ; Line bounding box, for ssget (vla-getboundingbox (vlax-ename->vla-object EntName) 'mn 'mx) (setq mn (mapcar '+ (list (* -1 AnArea) (* -1 AnArea) 0) (vlax-safearray->list mn))) (setq mx (mapcar '+ (list (* 1 AnArea) (* 1 AnArea) 0) (vlax-safearray->list mx))) (list mn mx) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun LM:3pcircle ( pt1 pt2 pt3 / cen md1 md2 vc1 vc2 ) (if (setq md1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) pt1 pt2) md2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) pt2 pt3) vc1 (mapcar '- pt2 pt1) vc2 (mapcar '- pt3 pt2) cen (inters md1 (mapcar '+ md1 (list (- (cadr vc1)) (car vc1) 0)) md2 (mapcar '+ md2 (list (- (cadr vc2)) (car vc2) 0)) nil ) ) (list cen (distance cen pt1)) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun AdjLines ( MyEnt / FF TheLines Pt1 Pt2 currentzoom No_Mutt Pt1A Pt1B AdjSS DelLines AdjCount NewSel ) ;;Set up (setq FF 0.0001) ; Fuzz Factor (setq TheLines (ssadd)) ; List of connecting lines (setq Pt1 (cdr (assoc 10 (entget MyEnt)))) ; End A point (setq Pt2 (cdr (assoc 11 (entget MyEnt)))) ; End B point ;; Zoom to line (setq currentzoom (list (getvar 'viewctr) (getvar 'viewsize))) ; Current Zoom (setq No_Mutt (getvar 'nomutt))(setvar 'NoMutt 1) ; do it quietly (vla-ZoomWindow (vlax-get-acad-object) ; Zoom to line bounding box +/- (vlax-3D-point (car (BNDBX MyEnt (* (linelength MyEnt 0) 0.25)))) (vlax-3D-point (cadr (BNDBX MyEnt (* (linelength MyEnt 0) 0.25)))) ) (setvar 'nomutt No_Mutt) ;; Assess each end (repeat 2 (setq Pt1A (mapcar '+ (list (* FF -1) (* FF -1)) Pt1)) ; Small area around end of line (setq Pt1B (mapcar '+ (list (* FF 1) (* FF 1)) Pt1)) (setq AdjSS (ssget "_C" Pt1A Pt1B '((0 . "LINE"))) ) ; select adjacent lines (setq DelLines (ssadd MyEnt)) ; Selection set to exclude some lines ;;Find if any line is very short (setq AdjCount 0) (while (< AdjCount (sslength AdjSS)) (if (= (linelength (ssname Adjss AdjCount) 0.0001) 0) (setq DelLines (ssadd (ssname Adjss AdjCount) DelLines)) ) (setq AdjCount (+ AdjCount 1)) ) ; end while ;;Delete these lines (setq AdjCount 0) (while (< AdjCount (sslength DelLines)) (setq AdjSS (ssdel (ssname DelLines AdjCount) AdjSS)) (setq AdjCount (+ AdjCount 1)) ) ; end while ;;Number of intersections (cond ((= (sslength AdjSS) 0) ; Found one adjacent intersection point (progn ) ) ; end cond ((= (sslength AdjSS) 1) ; Found one adjacent intersection point (setq TheLines (ssadd (ssname AdjSS 0) TheLines)) ) ; end cond (t ; All others (vla-ZoomWindow (vlax-get-acad-object) (vlax-3D-point (mapcar '+ (list (* -1 (distance Pt1 Pt2)) (* -1 (distance Pt1 Pt2))) Pt1) ) (vlax-3D-point (mapcar '+ (list (* 1 (distance Pt1 Pt2)) (* 1 (distance Pt1 Pt2))) Pt1) ) ) (princ "\nToo many line connections, Select a line") (redraw MyEnt 3) (setq NewSel (car (entsel))) ;;Error check this is a line (redraw MyEnt 4) (setq TheLines (ssadd NewSel TheLines)) ) ) ; end conds (setq Pt1A Pt2)(setq Pt2 Pt1)(setq Pt1 Pt1A) ; swap ends ) ; end repeat (setq No_Mutt (getvar 'nomutt))(setvar 'NoMutt 1) (vla-ZoomCenter (vlax-get-acad-object) (vlax-3d-point (car currentzoom)) (cadr currentzoom)) (setvar 'nomutt No_Mutt) TheLines ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun Int ( Ent1 Ent2 / Pt1A Pt1B Pt2A Pt2B PtC MyInt MyRadius ) ; Get intersection (setq Pt1A (cdr (assoc 10 (entget Ent1)))) ; End A point (setq Pt1B (cdr (assoc 11 (entget Ent1)))) ; End B point (setq Pt2A (cdr (assoc 10 (entget Ent2)))) ; End A point (setq Pt2B (cdr (assoc 11 (entget Ent2)))) ; End B point (if (equal Pt1A Pt2A 0.0001)(setq PtC Pt2B)) ; points not shared (if (equal Pt1B Pt2A 0.0001)(setq PtC Pt2B)) (if (equal Pt1A Pt2B 0.0001)(setq PtC Pt2A)) (if (equal Pt1B Pt2B 0.0001)(setq PtC Pt2A)) (setq MyInt (car (LM:3pcircle Pt1A Pt1B PtC)) ) ;;Intersection (setq MyRadius (cadr (LM:3pcircle Pt1A Pt1B PtC)) ) ;;Radius MyInt ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun trythis ( MyEnt AssessedLines ConnectedLines Int1 / p1 p2 TempLines acount AssessedLines Int1 Int2 ConnectedLines TryThisResult result) (setq p1 (cdr (assoc 10 (entget MyEnt)))) (setq p2 (cdr (assoc 11 (entget MyEnt)))) (if (= (linelength MyEnt 0.0001) 0) (princ " Short Line. ") (progn (repeat 2 (setq TempLines (AdjLines MyEnt)) ; returns up to 2 entities ;; Remove from list duplicated in AssessedLines (setq acount (sslength TempLines)) (while (> acount 0) (if (= (ssmemb (ssname TempLines (- acount 1) ) AssessedLines) nil) (progn ) (progn (setq TempLines (ssdel (ssmemb (ssname TempLines (- acount 1)) AssessedLines) TempLines)) ); end progn ) ; end if (setq acount (- acount 1)) ) ; end while (if (= (sslength TempLines) 0) (progn ; temp lines all assessed. ) (progn (setq AssessedLines (ssadd (ssname TempLines 0) AssessedLines)) ; add to assessed lines (if (= Int1 nil) (setq Int1 (Int MyEnt (ssname TempLines 0))) ) (setq Int2 (Int MyEnt (ssname TempLines 0))) (if (< (distance Int1 Int2) 1) (progn (setq ConnectedLines (ssadd (ssname TempLines 0) ConnectedLines)) ; add to Connected lines (setq TryThisResult (trythis (ssname TempLines 0) AssessedLines ConnectedLines Int1)) (setq AssessedLines (car TryThisResult)) (setq ConnectedLines (cadr TryThisResult)) (setq Int1 (caddr TryThisResult)) ) ; end progn ) ) ; End progn ) ; end if ) ; end repeat 2 ) ; end progn ) ; end if short MyEnt (setq result (list AssessedLines ConnectedLines Int1)) result ) ; end defun ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun c:Lines2Arc ( / ArcSS ArcLines ArcSSCount thisdrawing AnEnt AssessedLines Int1 ConnectedLines TryThisResult MyList P1 p1 p2 p3 counter acount) (setq ArcSS (ssget '((0 . "LINE")))) ; Selection Set (setq ArcLines (ssadd)) ; Selection Set for lines contained in an arc (setq ArcSSCount 0) ; A counter (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark thisdrawing) ; Start Undo (while (< ArcSSCount (sslength ArcSS)) ; while loop (setq AnEnt (ssname ArcSS ArcSSCount)); Next entity in loop (if (= AssessedLines nil)(setq AssessedLines (ssadd))) ; create selection set (if (= (linelength AnEnt 0.0001) 0) ; If the line is very short, ignore, move on (progn ) (progn ;;Reset for next entity (setq Int1 nil) (setq ConnectedLines nil) (setq ConnectedLines (ssadd AnEnt)) ; List for connected lines (if (or (ssmemb AnEnt ArcLines) ; If entity is in an arc.... (ssmemb AnEnt AssessedLines) ) ; Endor (progn ; do nothing ) (progn (setq TryThisResult (trythis AnEnt AssessedLines ConnectedLines Int1)) (setq ConnectedLines (cadr TryThisResult)) (setq Int1 (caddr TryThisResult)) (if (or (= ConnectedLines nil) (> 4 (sslength ConnectedLines)) ; If more than 3 entities its an arc. ) ; end or (progn ; not an arc ) (progn (setq MyList (uniquepoints ConnectedLines)) ; car: unique points, cadr: points list (setq ArcLines (LM:ss-union (list ArcLines ConnectedLines))) ; add entities to ignore list (if (= (car MyList) nil) (progn (princ "Full Circle") (setq P1 (car (cadr MyList)) ) (command "circle" Int1 P1) ) ; end progn (progn (setq p1 (car (car MyList))) ; first unique point (setq p2 (nth (/ (length (cadr MyList)) 2) (cadr MyList))) ; point within the arc (setq p3 (cadr (car MyList))) ; second unique point (setq counter 0) (while (< counter (sslength ConnectedLines)) (redraw (ssname ConnectedLines counter) 3) (setq counter (+ counter 1)) ) (command "delay" 50) (setq counter 0) (while (< counter (sslength ConnectedLines)) (redraw (ssname ConnectedLines counter) 4) (setq counter (+ counter 1)) ) (3parc p1 p2 p3) ; draw arc ) ; end progn ) ; end if full circle ) ; end progn ) ; end if arc returned ) ; end progn ) ; end if entity in an arc ) ;; end progn ) ; end while short line (setq AssessedLines (ssadd AnEnt AssessedLines)) ; List of all lines assessed (setq ArcSSCount (+ ArcSSCount 1) ) ; Increase count ) ; end while (setq acount 0) (repeat (sslength ArcLines) ; delete arc lines. Use entdel to keep command line quiet (entdel (ssname ArcLines acount)) (setq acount (+ acount 1)) ) (vla-endundomark thisdrawing) ; end undo (princ) ) - Edit 05/03/24- Updated to account for very short lines (in the order of 0.0005) - if the drawing contains short lines this length it will still complain.

assoc & subst are the key functions here - similar to how you might manipulate the DXF data returned by entget. You are working with an association list wherein the first element of each sublist represents a key, and the tail of the list represents the data associated with that key. You can use assoc to test whether a sublist with a given key exists, and then use subst to substitute the sublist with a modified version within the main list. For example - say you start with the following list: _$ (setq lst '(("2" "b") ("1" "a"))) (("2" "b") ("1" "a")) And you have the following new values: _$ (setq key "2" val "c") You can test whether the key exists using assoc: _$ (setq old (assoc key lst)) ("2" "b") Since it does, you can modify it using the value returned by assoc: _$ (setq new (append old (list val))) ("2" "b" "c") And finally, you can substitute it into the main list using subst: _$ (setq lst (subst new old lst)) (("2" "b" "c") ("1" "a")) If the key does not exist, you can use cons to push it onto the list: _$ (setq key "3" val "c") _$ (assoc key lst) nil _$ (setq lst (cons (list key val) lst)) (("3" "c") ("2" "b" "c") ("1" "a")) Putting this all together with an if statement to branch accordingly, we can write a function such as the following: (defun addtolist ( key val lst / old ) (if (setq old (assoc key lst)) (subst (append old (list val)) old lst) (cons (list key val) lst) ) ) _$ (setq lst '(("2" "b") ("1" "a"))) (("2" "b") ("1" "a")) _$ (setq lst (addtolist "2" "c" lst)) (("2" "b" "c") ("1" "a")) _$ (setq lst (addtolist "3" "d" lst)) (("3" "d") ("2" "b" "c") ("1" "a"))

Thanks Lee. I make use of it when I'm working on a big stretch of road and have some label/object(s) that I want to use over and over. It saves me from dealing with Clipboard or panning back to where I last placed the label/object. Another one (four to be precise), that predates my writing of this code: http://www.cadtutor.net/forum/showpost.php?p=305501&postcount=80 I still use these as well. All are useful in certain situations. I'm lazy but like to make the most out of my day.