|
Public Function addcircle(ByVal ptcen As Variant, ByVal radius As Variant) As AcadCircle
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(o To 2) As Double
Dim objcir As AcadCircle
Dim diameter As Double
'获得圆心
ptcen(0) = (pt1(0) + pt2(0)) / 2
ptcen(1) = (pt1(1) + pt2(1)) / 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) ^ -pt1(1) ^ 2
xyse = xy - pt3(0) ^ 2 - pt3(1) ^ 2
xysm = xy - pt2(0) ^ 2 - pt3(1) ^ 2
xy = (pi1(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) = (xysm * (pt1(0) - pt2(0)) - xyse * (pt2(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.addcircle(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, p3
End Sub
-------------------------------------
最前面的是函数表达式,后面的是运行的表达式,红色的函数值无效,那位帮忙分析下原因?谢谢
是用VBA做的。 |
|