Activex api vba 怎样 把圆弧转化为多段线？

slw7310

如题：使用 Activex  Api  或VBA 怎样才能将圆弧转化为多段线？ 请各位高手指教!谢谢。

zzyong00

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

zzyong00

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

slw7310

感谢zzyong00 您详尽的回复，非常管用。  谢谢！！