Activex api vba 怎样 把圆弧转化为多段线？
如题：使用 ActivexApi或VBA 怎样才能将圆弧转化为多段线？ 请各位高手指教!谢谢。 Public Sub ArctoPline() '圆弧转多线段Dim objSset As AcadSelectionSet, objArc As AcadArc
SelectLots "SSet", "Arc"
Set objSset = ThisDrawing.SelectionSets("SSet")
If objSset.Count = 0 Then Exit Sub
On Error GoTo err1
For Each objArc In objSset
Dim p1, p2, points(3) As Double
If objArc.ObjectName <> "AcDbArc" Then Exit Sub
p1 = objArc.StartPoint
p2 = objArc.EndPoint
points(0) = p1(0)
points(1) = p1(1)
points(2) = p2(0)
points(3) = p2(1)
Dim plineObj As AcadLWPolyline
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
If objArc.EndAngle - objArc.StartAngle > 0 Then
plineObj.SetBulge 0, Tan((objArc.EndAngle - objArc.StartAngle) / 4)
Else
plineObj.SetBulge 0, Tan((objArc.EndAngle - objArc.StartAngle + 2 * _
3.1415926) / 4)
End If
'凸度是多段线顶点列表中选定顶点和下一顶点之间的圆弧所包含角度的 1/4 的正切值。
'负的凸度值表示圆弧从选定顶点到下一顶点为顺时针方向。凸度为0 表示直线段，凸度为1表示半圆。
plineObj.Update
Next
For Each objArc In objSset
objArc.Delete
Next
'ZoomAll
Exit Sub
err1:
Debug.Print Err.Description
Err.Clear
Exit Sub
End Sub Private Sub SelectLots(ByVal Ssetname As String, ByVal objName As String)
Dim sSetObj As AcadSelectionSet, flag As Boolean
For Each sSetObj In ThisDrawing.SelectionSets
If sSetObj.name = Ssetname Then
flag = True
Exit For
End If
Next
If flag Then sSetObj.Delete '创建集合，如集存在，则删除，新建
Set sSetObj = ThisDrawing.SelectionSets.Add(Ssetname)
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = objName
Dim groupCode As Variant, dataCode As Variant
groupCode = gpCode
dataCode = dataValue
ThisDrawing.Utility.Prompt "请选择对象，可以框选" & vbCrLf
sSetObj.SelectOnScreen groupCode, dataCode
End Sub
感谢zzyong00 您详尽的回复，非常管用。谢谢！！
页:
[1]