通过三点返回一个圆弧自定义函数的完善
通过三点返回一个圆弧自定义函数的完善：在明经社区中的自定义函数VBA专栏中有一个通过三点返回一个圆弧函数ThreePntArc，我在使用的过程中发现它不太完善，我进一步对它进行了完善，完善的代码如下：不到之处请指正。
Public Function ThreePntArc(vStart, vNext, vEnd) As AcadArc
Dim objArc As AcadArc
Dim objUtil As AcadUtility
Dim objSpace As AcadBlock
Dim varCenter As Variant
Dim dblCenter(2) As Double
Dim dblRad As Double
Dim dblSang As Double
Dim dblEang As Double
Dim blnClockWise As Boolean
Dim dblBase1 As Double
Dim dblBase2 As Double
Dim dblBase3 As Double
Dim strPrmt As String
On Error GoTo Err_Control
varCenter = Center_3_pnts(vStart, vNext, vEnd)
dblCenter(0) = varCenter(0)
dblCenter(1) = varCenter(1)
Set objUtil = ThisDrawing.Utility
'需要知道选择点的方向
dblBase1 = objUtil.AngleFromXAxis(dblCenter, vStart)
dblBase2 = objUtil.AngleFromXAxis(dblCenter, vNext) + (2 * 3.1415926 - dblBase1)
dblBase3 = objUtil.AngleFromXAxis(dblCenter, vEnd) + (2 * 3.1415926 - dblBase1)
If dblBase2 > 2 * 3.1415926 Then
dblBase2 = dblBase2 - 2 * 3.1415926
End If
If dblBase3 > 2 * 3.1415926 Then
dblBase3 = dblBase3 - 2 * 3.1415926
End If
If dblBase2 < dblBase3 Then
blnClockWise = True
ElseIf dblBase2 > dblBase3 Then
blnClockWise = False
ElseIf dblBase2 = dblBase3 Then
'用户选定的是一条线上的点。'你可在这里增加处理的内容，但用了 Center_3_Pnt 函数则不会出现问题
End If
'在这里去掉了中心点的Z坐标，但也可保留..
If ThisDrawing.ActiveSpace = acModelSpace Then
Set objSpace = ThisDrawing.ModelSpace
'保留Z坐标时可使用以下语句
'dblCenter(2) = ThisDrawing.ElevationModelSpace
Else
Set objSpace = ThisDrawing.PaperSpace
'在图纸空间中匹配
'dblCenter(2) = ThisDrawing.ElevationPaperSpace
End If
'或者你可使用选定点上的某一个值:
'dblCenter(2) = vStart(2)
dblRad = Sqr((varCenter(0) - vStart(0)) ^ 2 + (varCenter(1) - vStart(1)) ^ 2)
dblSang = objUtil.AngleFromXAxis(dblCenter, vStart)
dblEang = objUtil.AngleFromXAxis(dblCenter, vEnd)
If blnClockWise Then
Set objArc = objSpace.AddArc(dblCenter, dblRad, dblSang, dblEang)
Else
Set objArc = objSpace.AddArc(dblCenter, dblRad, dblEang, dblSang)
End If
Set ThreePntArc = objArc
Exit_Here:
Exit Function
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Function
页:
[1]