How about using BOUNDARY command with Polyline object type option?.It creates a closed circular polyline (LWPOLYLINE) provided there is no overlaping. Here is some code based on the idea.
Sub CircleToPline()
On Error Resume Next
Dim vPickPnt As Variant
Dim objCircle As AcadCircle
With ThisDrawing
.Utility.GetEntity objCircle, vPickPnt, "Select a circle to convert: "
If Err.Number = 0 Then
Dim strEntLyr, StrEntLType As String
Dim EntColor, vCenPnt As Variant
Dim strCommand As String
Dim dblStartWidth, dblEndwidth
Dim strCenPnt As String
Dim objPLine As AcadLWPolyline
Dim objSS As AcadSelectionSet
'|<-- Collect object properties for later use -->
With objCircle
strEntLyr = .Layer: StrEntLType = .Linetype: EntColor = .Color
End With
dblStartWidth = .Utility.GetReal("Enter polyline width <0>: ")
If IsEmpty(dblStartWidth) Then
dblStartWidth = 0
End If
dblEndwidth = dblStartWidth
vCenPnt = objCircle.Center
strCenPnt = Trim(str(vCenPnt(0))) & "," & Trim(str(vCenPnt(1)))
'|<-- Command sequence: -boundary <point> [advanced] [object type] [polyline]-->|
strCommand = "-boundary" & vbCr & strCenPnt & vbCr & "a" & vbCr & _
"o" & vbCr & "p" & vbCr & vbCr & vbCr
.SendCommand strCommand
Set objSS = .SelectionSets.Add("LastEnt")
objSS.Select acSelectionSetLast
Set objPLine = objSS(0)
'|<-- Set back the object properties -->|
With objPLine
.Layer = strEntLyr: .Linetype = StrEntLType: .Color = EntColor
End With
Dim i As Integer
For i = 0 To 1
objPLine.SetWidth i, dblStartWidth, dblEndwidth
Next
objCircle.Delete
objSS.Delete
ThisDrawing.Regen acActiveViewport
Else
.Utility.prompt "a circle must be selected...."
End If
End With
End Sub
I know that we have already discussed better options. Does anybody know how to create a boundary from a closed object programmatically without using the SendCommand procedure? Then this program can be improved a lot.
har!s
That sure is an awful lot of code to draw a donut, but then again, so is mine.