通过三点返回一个圆弧自定义函数的完善

miaoph

通过三点返回一个圆弧自定义函数的完善：
在明经社区中的自定义函数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