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

slw7310 · 发表于 2014-10-8 16:01:00

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

zzyong00 · 发表于 2014-10-11 08:48:00

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 · 发表于 2014-10-11 08:49:00

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