这个程序是两年前写的。
并不是很完美,当一个内角接近180度时,CAD会死掉(现在不想花精力修正了)
Sub try() Dim PA, PB, PC As Variant PA = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入三角形的第一个角点:") PB = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入三角形的第二个角点:") PC = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入三角形的第三个角点:") pi = 3.1415926535 '获得三个内角 Dim aa As Double, bb As Double, cc As Double aa = Abs(ThisDrawing.Utility.AngleFromXAxis(PA, PB) _ - ThisDrawing.Utility.AngleFromXAxis(PA, PC)) If aa > pi Then aa = 2 * pi - aa bb = Abs(ThisDrawing.Utility.AngleFromXAxis(PB, PA) _ - ThisDrawing.Utility.AngleFromXAxis(PB, PC)) If bb > pi Then bb = 2 * pi - bb cc = Abs(ThisDrawing.Utility.AngleFromXAxis(PC, PB) _ - ThisDrawing.Utility.AngleFromXAxis(PC, PA)) If cc > pi Then cc = 2 * pi - cc '获得三边的长度 Dim a As Double, d As Double, c As Double a = dis(PB, PC) b = dis(PC, PA) c = dis(PA, PB) '赋初值 Dim R1 As Double, R2 As Double, R3 As Double, R11 As Double R1 = 0.005 * (dis(PA, PB) + dis(PB, PC) + dis(PC, PA)) '中间变量 Dim ta As Double, tb As Double, tc As Double ta = 1 / Tan(aa / 2): tb = 1 / Tan(bb / 2): tc = 1 / Tan(cc / 2) R11 = R1 Dim S2 As Double, S3 As Double Dim LR2 As Double, LR3 As Double Do R1 = R11 S2 = (4 - 4 * ta * tb) * R1 * R1 + 4 * c * tb S3 = (4 - 4 * tc * ta) * R1 * R1 + 4 * b * tc R2 = (-2 * R1 + Sqr(S2)) / (2 * tb) R3 = (-2 * R1 + Sqr(S3)) / (2 * tc) LR2 = -1 / ta + (2 * (4 - 4 * ta * tb) * R1) / (4 * ta * Sqr(S2)) LR3 = -1 / tc + (2 * (4 - 4 * tc * ta) * R1) / (4 * tc * Sqr(S3)) fx = tb * R2 * R2 + tc * R3 * R3 + 2 * R2 * R3 - a flx = 2 * tb * R2 * LR2 + 2 * tc * R3 * LR3 + 2 * R2 * LR3 + 2 * R3 * LR2 R11 = R1 - fx / flx Loop While Abs(R11 - R1) > 0.0000000000001 Dim paa(2) As Double, pbb(2) As Double, pcc(2) As Double Dim Dab, Dbc, Dca As Double Dab = dis(PC, PA) / dis(PC, PB) Dbc = dis(PA, PB) / dis(PA, PC) Dca = dis(PB, PC) / dis(PB, PA) paa(0) = (PB(0) + Dbc * PC(0)) / (1 + Dbc) paa(1) = (PB(1) + Dbc * PC(1)) / (1 + Dbc) pbb(0) = (PC(0) + Dca * PA(0)) / (1 + Dca) pbb(1) = (PC(1) + Dca * PA(1)) / (1 + Dca) pcc(0) = (PA(0) + Dab * PB(0)) / (1 + Dab) pcc(1) = (PA(1) + Dab * PB(1)) / (1 + Dab) Dim Aang As Double, Bang As Double, Cang As Double Aang = ThisDrawing.Utility.AngleFromXAxis(PA, paa) Bang = ThisDrawing.Utility.AngleFromXAxis(PB, pbb) Cang = ThisDrawing.Utility.AngleFromXAxis(PC, pcc) Dim p1, p2, p3 As Variant p1 = ThisDrawing.Utility.PolarPoint(PA, Aang, R1 * R1 / Sin(aa / 2)) p2 = ThisDrawing.Utility.PolarPoint(PB, Bang, R2 * R2 / Sin(bb / 2)) p3 = ThisDrawing.Utility.PolarPoint(PC, Cang, R3 * R3 / Sin(cc / 2)) Dim c1 As AcadCircle, c2 As AcadCircle, c3 As AcadCircle Set c1 = ThisDrawing.ModelSpace.AddCircle(p1, R1 * R1) Set c2 = ThisDrawing.ModelSpace.AddCircle(p2, R2 * R2) Set c3 = ThisDrawing.ModelSpace.AddCircle(p3, R3 * R3)
End Sub Function dis(PA, PB As Variant) As Double dis = ((PA(0) - PB(0)) ^ 2 + (PA(1) - PB(1)) ^ 2 + (PA(2) - PB(2)) ^ 2) ^ 0.5 End Function
用VBALOAD命令加载,VBARUN命令运行。 |