[转帖]VBA-三点划弧

Private Function GetCenOf3Pt(pt1 As Variant, pt2 As Variant, pt3 As Variant, ByRef radius As Double) As Variant
''''根据三点计算出圆心和半径
Dim xysm, xyse, xy As Double
Dim ptCen(2) As Double
xy = pt1(0) ^ 2 + pt1(1) ^ 2
xyse = xy - pt3(0) ^ 2 - pt3(1) ^ 2
xysm = xy - pt2(0) ^ 2 - pt2(1) ^ 2
xy = (pt1(0) - pt2(0)) * (pt1(1) - pt3(1)) - (pt1(0) - pt3(0)) * (pt1(1) - pt2(1))
'''判断参数有效性
If Abs(xy) < 0.000001 Then
MsgBox "所输入的参数无法创建圆形！"
Exit Function
End If
'获得圆心和半径
ptCen(0) = (xysm * (pt1(1) - pt3(1)) - xyse * (pt1(1) - pt2(1))) / (2 * xy)
ptCen(1) = (xyse * (pt1(0) - pt2(0)) - xysm * (pt1(0) - pt3(0))) / (2 * xy)
ptCen(2) = 0
radius = Sqr((pt1(0) - ptCen(0)) * (pt1(0) - ptCen(0)) + (pt1(1) - ptCen(1)) * (pt1(1) - ptCen(1)))
If radius < 0.000001 Then
MsgBox "半径过小！"
Exit Function
End If
''函数返回圆心的位置，而半径则在参数中通过引用方式返回
GetCenOf3Pt = ptCen
End FunctionPublic Function AddArc3Pt(ByVal ptSt As Variant, ByVal ptSc As Variant, ByVal ptEn As Variant) As AcadArc
''''三点法创建圆弧
Dim objArc As AcadArc
Dim ptCen As Variant
Dim radius As Double
ptCen = GetCenOf3Pt(ptSt, ptSc, ptEn, radius)
If isClockWise(ptCen, ptSt, ptSc, ptEn) Then
Set objArc = AddArcCSEP(ptCen, ptSt, ptEn)
Else
Set objArc = AddArcCSEP(ptCen, ptEn, ptSt)
End If
objArc.Update
Set AddArc3Pt = objArc
End FunctionPrivate Function AddArcCSEP(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal ptEn As Variant) As AcadArc
Dim objArc As AcadArc
Dim radius As Double
Dim stAng, enAng As Double
''计算半径
radius = 100 'GetDistance(ptCen, ptSt)
''计算起点角度和终点角度
stAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt)
enAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptEn)
Set objArc = ThisDrawing.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
objArc.Update
Set AddArcCSEP = objArc
End Function
'判断三点的方向
Function isClockWise(ptCen, ptSt, ptSc, ptEn) As Boolean
a1 = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt)
a2 = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSc)
a3 = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptEn)
isClockWise = (a1 < a2) Xor (a2 < a3) Xor (a1 < a3)
End Function
Sub ls()
  Dim aa As AcadArc
  Dim pp(0 To 2) As Double, ppp(0 To 2) As Double, pppp(0 To 2) As Double
  pp(0) = 0: pp(1) = 10: pp(2) = 0
  ppp(0) = 10: ppp(1) = 100: ppp(2) = 0
  pppp(0) = -20: pppp(1) = -110: pppp(2) = 0
  Set aa = AddArcCSEP(pp, ppp, pppp)
  
End Sub