AutoCAD VBA 直线、圆、圆弧转化为多段线

转化多段线，代码如下。

Private Function AddLWPlineSeg(ByVal ptSt As Variant, ByVal ptEn As Variant, ByVal width As Double) As AcadLWPolyline
Dim objPline As AcadLWPolyline
Dim ptArr(0 To 3) As Double
ptArr(0) = ptSt(0)
ptArr(1) = ptSt(1)
ptArr(2) = ptSt(0)
ptArr(3) = ptSt(1)
Set objplin = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
objPline.ConstantWidth = width
objPline.Update
Set AddLWPlineSeg = objPline
End Function
Private Function AddLWPlineCircle(ByVal ptCen As Variant, ByVal radius As Double, ByVal width As Double) As AcadLWPolyline
Dim objPline As AcadLWPolyline
Dim ptArr(0 To 5) As Double
ptArr(0) = ptCen(0) + radius
ptArr(1) = ptCen(1)
ptArr(2) = ptCen(0) - radius
ptArr(3) = ptCen(1)
ptArr(4) = ptCen(0) + radius
ptArr(5) = ptCen(1)
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
objPline.ConstantWidth = width
objPline.SetBulge 0, 1
objPline.SetBulge 1, 1
objPline.SetBulge 2, 1
objPline.Closed = True
objPline.Update
Set AddLWPlineCircle = objPline
End Function
Private Function AddLWPlineArc(ByVal ptCen As Variant, ByVal radius As Double, ByVal angleSt As Double, ByVal angleEn As Double, ByVal width As Double) As AcadLWPolyline
Dim objPline As AcadLWPolyline
Dim ptArr(0 To 3) As Double
ptArr(0) = ptCen(0) + radius * Cos(angleSt)
ptArr(1) = ptCen(1) + radius * Sin(angleSt)
ptArr(2) = ptCen(0) + radius * Cos(angleEn)
ptArr(3) = ptCen(1) * radius * Sin(angleEn)
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
objPline.ConstantWidth = width
If angleEn < angleSt Then
angleSt = angleSt - 8 * Atn(1)
End If
objPline.SetBulge 0, Tan((angleEn - angleSt) / 4)
objPline.SetBulge 1, 0
objPline.Update
Set AddLWPlineArc = objPline
End Function
Public Function TransformToPolyline()
On Error Resume Next
Dim SSet As AcadSelectionSet
If Not IsNull(ThisDrawing.SelectionSets.Item("Example")) Then
Set SSet = ThisDrawing.SelectionSets.Item("Example")
SSet.Delete
End If
Set SSet = ThisDrawing.SelectionSets.Add("Example")
Dim FilterType(0 To 6) As Integer
Dim FilterData(0 To 6) As Variant
FilterType(0) = -4
FilterData(0) = "<or"
FilterType(1) = 0
FilterData(1) = "Arc"
FilterType(2) = 0
FilterData(2) = "Circle"
FilterType(3) = 0
FilterData(3) = "Line"
FilterType(4) = 0
FilterData(4) = "Polyline"
FilterType(5) = 0
FilterData(5) = "LWPolyline"
FilterType(6) = -4
FilterData(6) = "or>"
ThisDrawing.Utility.Prompt "选择要改变线宽的对象（直线、圆、弧和多段线）"
SSet.SelectOnScreen FilterType, FilterData
Dim width As Double
width = ThisDrawing.Utility.GetReal("输入对象的线宽：")
Dim ent As AcadEntity
Dim objPline As AcadLWPolyline
Dim ptStart, ptCenter, ptEnd
Dim radius As Double
Dim angleSt As Double, angleEn As Double
For Each ent In SSet
Select Case ent.ObjectName
Case "AcDbLine"
ptStart = ent.StartPoint
ptEnd = ent.EndPoint
AddLWPlineSeg ptStart, ptEnd, width
ent.Delete
Case "AcDbArc"
ptCenter = ent.Center
radius = ent.radius
angleSt = ent.StartAngle
angleEn = ent.EndAngle
AddLWPlineArc ptCenter, radius, angleSt, angleEn, width
ent.Delete
Case "AcDbCircle"
ptCenter = ent.Center
radius = ent.radius
AddLWPlineCircle ptCenter, radius, width
ent.Delete
Case "AcDb2dPolyline", "AcDb3dPolyline", "AcDbPolyline"
ent.ConstantWidth = width
ent.Update
End Select
Next ent
SSet.Delete
End Function

代码完。