AutoCAD VBA创建圆

AutoCAD VBA创建圆，包括利用圆心半径、圆心直径、两点法和三点发四种方式，代码如下。

Public Function AddCircle(ByVal ptCen As Variant, ByVal radius As Variant) As Variant
Dim objCir As AcadCircle
Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, radius)
Set AddCircle = objCir
End Function
Public Function AddCircleCD(ByVal ptCen As Variant, ByVal diameter As Variant) As AcadCircle
Dim objCir As AcadCircle
Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, diameter / 2)
Set AddCircleCD = objCir
End Function
Public Function AddCircle2P(ByVal pt1 As Variant, ByVal pt2 As Variant) As AcadCircle
Dim ptCen(0 To 2) As Double
Dim objCir As AcadCircle
Dim diateter As Double
ptCen(0) = (pt1(0) + pt2(0)) / 2
ptCen(1) = (pt1(1) + pt2(2)) / 2
ptCen(2) = 0
diameter = Sqr((pt2(0) - pt1(0)) ^ 2 + (pt2(1) - pt1(1)) ^ 2)
Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, diameter / 2)
Set AddCircle2P = objCir
End Function
Public Function AddCircle3P(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal pt3 As Variant) As AcadCircle
Dim xysm, xyse, xy As Double
Dim ptCen(0 To 2) As Double
Dim radius As Double
Dim objCir As AcadCircle
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
Set objCir = ThisDrawing.ModelSpace.addcir(ptCen, radius)
Set AddCircle3P = objCir
End Function
Public Sub TestCircle()
Dim pt1, pt2, pt3 As Variant
Dim radius As Double
pt1 = ThisDrawing.Utility.GetPoint(, "指定圆心：")
radius = ThisDrawing.Utility.GetReal("输入半径：")
AddCircle pt1, radius
pt1 = ThisDrawing.Utility.GetPoint(, "指定圆心：")
radius = ThisDrawing.Utility.GetReal("输入直径：")
AddCircleCD pt1, radius
pt1 = ThisDrawing.Utility.GetPoint(, "输入第一点：")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "输入第二点：")
AddCircle2P pt1, pt2
pt1 = ThisDrawing.Utility.GetPoint(, "输入第一点：")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "输入第二点：")
pt3 = ThisDrawing.Utility.GetPoint(pt2, "输入第三点：")
AddCircle3P pt1, pt2, pt3
End Sub

代码完。

最后一种方式错误提示：对象不支持该属性或方法。