I want to convert many straight lines into one arc.

February 25

Try this one, I think it is a bit more reliable... but might not be.. in testing with your sample it was working - for me.

Command: L2Arc

Select all entities and it should locate arcs and convert lines to arcs. Arc is defined if 3 or more adjacent lines have a similar perpendicular intersection and are a similar line length

(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 ConnectedArc ( MyEnt INark / FF LineSS ConnectedLines MyList Pt AnEnt Pt1 Pt2 MyEntLen PtA PtB MySS CLCount IntEnt MidPt MyAng PtC Int1 MyRadius StopLoop Pt3 APtA APtB NewLine Int2 ARadius)
;;returns selection set of lines sharing a common perpendicular line intersection point
;;sort of, includes fuzz factor

;;;;Sub functions
  (defun DrawLine (pt1 pt2) (entmakex (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2) ))) ; draws a line
  (defun mid-pt ( p1 p2 / ) (polar p1 (angle p1 p2) (/ (distance p1 p2) 2.) ) )           ; mid point p1 to p2
  (defun LM:intersections ( ob1 ob2 mod / lst rtn ) ; Intersection between 2 lines
    (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)
  )
;;;;End Sub functions


  (setq FF 0.002)                               ; Fuzz factor. Proportion of the lengths
  (setq ConnectedLines (ssadd MyEnt))           ; List for lines connected to selected entity

  (setq Pt1 (cdr (assoc 10 (entget MyEnt))))    ; End A point
  (setq Pt2 (cdr (assoc 11 (entget MyEnt))))    ; End B point
  (setq PtA Pt1)
  (setq PtB Pt2)
  (setq AnEnt MyEnt)

  (repeat 2
    (setq Pt1A (mapcar '+ (list (* FF -1) (* FF -1)) PtA)) ; Small area around end of line
    (setq Pt1B (mapcar '+ (list (* FF  1) (* FF  1)) PtA))
    (setq MySS (ssget "_C" Pt1A Pt1B '((0 . "LINE"))) )   ; select adjacent lines

    (if (= (sslength MySS) 2) ; Found one adjacent intersection point
      (progn
        (setq MySS (ssname (ssdel AnEnt MySS) 0))      ; Next line
        (if (equal (cdr (assoc 10 (entget MySS))) PtA 0.001) ;find connected end & points
          (progn
            (setq APtA (cdr (assoc 10 (entget MySS)))) ; next line end points
            (setq APtB (cdr (assoc 11 (entget MySS)))) ; next line end points
          )    
          (progn
            (setq APtA (cdr (assoc 11 (entget MySS)))) ; next line end points
            (setq APtB (cdr (assoc 10 (entget MySS)))) ; next line end points
          )
        ) ; end if connected ends

        (setq Int1 (car (LM:3pcircle PtA PtB APtB)) )     ;;Intersection 
        (setq MyRadius1 (cadr (LM:3pcircle PtA PtB APtB)) );;Radius
      ) ; end progn
    )   ; end if MySS length 2

    (setq StopLoop "No")                                  ; Marker to stop looping
    (while (= StopLoop "No")
      (setq PtX (mapcar '+ (list (* FF -1) (* FF -1)) PtA)); Small area around end of line
      (setq PtY (mapcar '+ (list (* FF  1) (* FF  1)) PtA)); Other corner
      (setq MySS (ssget "_C" PtX PtY '((0 . "LINE"))) )   ; select joining lines
      (if (= (sslength MySS) 2)                           ; If only 2 joining lines
        (progn
          (setq MySS (ssdel AnEnt MySS))      ; Next line
          (setq AnEnt (ssname MySS 0))        ; next line entity name
          (if 
            (or
              (ssmemb AnEnt ConnectedLines)
              (ssmemb AnEnt INark)
            )
            (progn
              (princ "Repeating Selection")
              (setq StopLoop "Yes")
            )
            (progn
              (if (equal (cdr (assoc 10 (entget AnEnt))) ptA 0.001) ;find connected end & points
                (progn
                  (setq APtA (cdr (assoc 10 (entget AnEnt)))) ; next line end points
                  (setq APtB (cdr (assoc 11 (entget AnEnt)))) ; next line end points
                )    
                (progn
                  (setq APtA (cdr (assoc 11 (entget AnEnt)))) ; next line end points
                  (setq APtB (cdr (assoc 10 (entget AnEnt)))) ; next line end points
                )
              ) ; end if connected ends

              (setq Int2 (car (LM:3pcircle PtB APtA APtB) ))
              (setq MyRadius2 (cadr (LM:3pcircle PtA PtB (if (equal PtA APtA FF) APtB APtA)) ))

              (if (and
                  (equal Int1 Int2 (* MyRadius1 FF))
                  (equal (distance Pt1 Pt2) (distance APtA APtB) (* MyRadius1 FF))
                ) ; end end
                (progn
                  (setq ConnectedLines (ssadd AnEnt ConnectedLines)) ; add next line to list
                ) ; end progn
                (progn
                  (setq StopLoop "Yes")
                ) ; end prog
              ) ; end if intersection match
              (setq PtA APtB)
            ) ; end progn
          ) ; end if connected lines
        ) ; end progn
        (progn
          (setq StopLoop "Yes")
        ) ; end progn
      ) ; end if SSlength = 2
    ) ; end while stoploop

;;Reset for repeat
    (setq PtA Pt2)
    (setq PtB Pt1)
    (setq AnEnt MyEnt)
  ) ; end repeat



;  (princ "\n")(princ (sslength ConnectedLines))(princ " Connected Lines Found")
  (list ConnectedLines Int1 MyRadius1 (sslength ConnectedLines)) ; Return Connected Lines

)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:l2arc (/ thisdrawing ArcSS ArcLines ArcSSCount MyEnt MyArc MySS MyList p1 p2 p3 acount)
;;sub functions
  (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 / lst ocs pt1 pt2 pt3 ) ; 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 LM:ss-union ( lst / out )
    (setq lst (vl-sort lst '(lambda ( a b ) (> (sslength a) (sslength b))))
          out (car lst)
    )
    (foreach ss (cdr lst)
      (repeat (setq i (sslength ss))
        (ssadd (ssname ss (setq i (1- i))) out)
      )
    )
    out
  )
;;end sub functions

;;'Main' stuff apart from the functions above
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark thisdrawing)         ; Start Undo
  (setq ArcSS (ssget '((0 . "LINE"))))    ; Selection Set
  (setq ArcLines (ssadd))                 ; List for lines contained in an arc

  (setq ArcSSCount 0)                     ; A counter
  (while (< ArcSSCount (sslength ArcSS))  ; while loop
    (setq MyEnt (ssname ArcSS ArcSSCount)); Next entity in loop
    (if (ssmemb MyEnt ArcLines)           ; If entity is in an arc....
      (progn                              ; do nothing
      )
      (progn
        (setq MyArc (ConnectedArc MyEnt ArcLines)) ; Find all lines connected that are in an arc
        (setq MySS (car MyArc))           ; Entities that make arc
        (if (or 
              (= MySS nil)
              (> 3 (sslength MySS))       ; If more than 3 entities its an arc. Can change 3 to suit
            ) ; end or
          (progn ; not an arc
          )
          (progn
            (setq MyList (uniquepoints MySS)) ; car: unique points, cadr: points list
            (setq ArcLines (LM:ss-union (list ArcLines MySS))) ; add entities to ignore list
            (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
            (3parc p1 p2 p3)              ; draw arc
          ) ; end progn
        )   ; end if arc returned
       ) ; end progn
     )   ; end if entity in an arc
    (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)
)

February 26

It's the start of a fun week.

I tried it with the Lisp you uploaded today.

Today I discovered another problem.
Strangely, there was a phenomenon in which the shape changed even though the line was not selected.
There was also a phenomenon where some lines disappeared.

I will upload the drawing.

TEST - (24.02.26).dxf

February 26

OK I think for me this is just to adjust the limits of what it thinks are part of the same arc

Edited February 26 by Steven P

March 1

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.

Edited March 6 by Steven P
Updated Code

March 4

I would like to express my gratitude first.

I used Lisp you made for 3 days.

It definitely works better than the previous one.

Is it possible that the problem areas you mentioned cannot be improved?

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

We also found that the hole became larger with some use.
I also found areas where the lines overlap.
We also discovered areas where Lisp was not applicable.

We also found cases where the results were different when the shape was the same but scaled differently.

Thank you to everyone who helps us every time.

NG sample 24.03.04.dxf

March 4

Interesting and thanks, this is one I am going to keep for myself so worth me taking the time over it, I should have time this week to look at the very small lines and small gaps.

Having a quick look, some of the circles are not -quite- identical (overlaid one on top of another, overkill, and there are some lines left from both) which might explain that.

March 6

I too deal with a lot of files each day where the radii are broken into many small straight lines.
I think one of my clients creates the Rads in their Cad environment using splines, and then converts them into polylines which makes them change to these small line segments.
Please keep up the great work Steven P, this appears to have been progressing nicely, and I can't wit to see the final result

Sign In

I want to convert many straight lines into one arc.

Recommended Posts

Steven P

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

SLW210

mhupp

Jonathan Handojo

Posted Images

BEAR

Steven P

Steven P

BEAR

Steven P

Sharper

Join the conversation

SLW210

mhupp

Jonathan Handojo

Tutorials

Forums

Activity