如下图， dwg图中若干图形，运行代码后提示选择两个圆，然后判断两个圆位置关系和相交点坐标:
本例难点在于通过几何知识求出交点坐标。
几何背景
假设有两个圆：
- 圆1：圆心 ( O_1(x_1, y_1) )，半径 ( r_1 )
- 圆2：圆心 ( O_2(x_2, y_2) )，半径 ( r_2 )
圆心 ( O_1 ) 和 ( O_2 ) 之间的距离为 d ，交点位于两圆的公共弦上。我们的目标是通过代数推导找到公共弦与两圆圆心的几何关系，并证明 a 的代数式。
几何分析
两个圆的交点（如果有两个）在公共弦上，且公共弦的中垂线经过两个圆心 O_1 和O_2 的连线。我们定义 P_0 为公共弦的中点，且它在两个圆心连线 O_1O_2 上。定义：
a 是圆心 O_1到点 P_0 的距离。
h 是P_0 到交点的垂直距离。
因此，我们可以将 a 定义为从 O_1到公共弦 即 P_0 的距离。
利用余弦定理推导 a
利用两圆的交点与圆心的几何关系，首先计算 \( a \) 的代数表达式。
1. 定义圆心距离 d：
d = sqrt{(x_2 - x_1)^2 + (y_2 - y_1)^2
2. **两圆相交**：假设两个圆有两个交点，公共弦 \( AB \) 将连线 \( O_1O_2 \) 分成两部分：从 \( O_1 \) 到公共弦的距离 \( a \)，和从 \( O_2 \) 到公共弦的另一段距离。
3. **两圆的关系**：根据几何原理，有：
r_1^2 = a^2 + h^2
r_2^2 = (d - a)^2 + h^2 
其中，h 是从 P_0 到交点的垂直距离。
4. 消去 h^2：从公式 (1) 和 (2) 可以消去 \( h^2 \)，得到：
r_1^2 - a^2 = r_2^2 - (d - a)^2
5. **展开并整理**：
r_1^2 - a^2 = r_2^2 - (d^2 - 2ad + a^2)
r_1^2 - a^2 = r_2^2 - d^2 + 2ad - a^2
r_1^2 - r_2^2 + d^2 = 2ad
6. 解出 a ：
a = (r1 ^ 2 - r2 ^ 2 + d ^ 2) / (2 * d)
h = Sqr(r1 ^ 2 - a ^ 2)
通过这个公式，我们可以进一步计算出交点的坐标，根据三角函数，详见代码。
附部分计代码如下：
#If VBA7 Then
' 64位系统声明
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
' 32位系统声明
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
#If VBA7 Then
' 64位系统声明
Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
' 32位系统声明
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
Sub SelectTwoCircles()
'yngqq@2024年9月10日21:40:46
Dim escapePressed As Boolean
escapePressed = False
Dim ent As AcadEntity
Dim circle1 As AcadCircle
Dim circle2 As AcadCircle
Dim selectionCount As Integer
Dim center1 As Variant
Dim center2 As Variant
Dim x1 As Double, y1 As Double, r1 As Double
Dim x2 As Double, y2 As Double, r2 As Double
selectionCount = 0
2000:
Do While selectionCount < 2
' 如果按下ESC键，退出循环
If GetAsyncKeyState(vbKeyEscape) <> 0 Then
If GetAsyncKeyState(vbKeyEscape) <> 0 Then
ThisDrawing.Utility.Prompt "检测到ESC键，退出循环 " & vbCrLf
MsgBox "已按下Esc键,退出程序", , "CopyRight@yngqq"
GoTo errocontrol
End If
End If
DoEvents
ThisDrawing.Utility.Prompt "请选择第" & (selectionCount + 1) & "个圆: "
' If Err Then
' Err.Clear
' GoTo 2000
' End If
On Error Resume Next
ThisDrawing.Utility.GetEntity ent, basePnt, " "
If Err Then
Err.Clear
GoTo 2000
End If
' 判断用户是否选择了一个圆
If TypeOf ent Is AcadCircle Then
selectionCount = selectionCount + 1
If selectionCount = 1 Then
' 第一个圆
Set circle1 = ent
ElseIf selectionCount = 2 Then
' 第二个圆
Set circle2 = ent
End If
Else
ThisDrawing.Utility.Prompt "选择的不是圆，请重新选择。" & vbCrLf
End If
Loop
' 获取圆心坐标和半径
' On Error GoTo 0
center1 = circle1.Center
center2 = circle2.Center
x1 = center1(0): y1 = center1(1): r1 = circle1.Radius
x2 = center2(0): y2 = center2(1): r2 = circle2.Radius
Call FindCircleIntersection(x1, y1, r1, x2, y2, r2)
errocontrol:
End Sub
Public Function FindCircleIntersection(x1 As Double, y1 As Double, r1 As Double, x2 As Double, y2 As Double, r2 As Double) As Variant
Dim d As Double
d = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2)
' 判断圆的关系
If d > r1 + r2 Then
MsgBox "两个圆不相交"
ElseIf d < Abs(r1 - r2) Then
MsgBox "一个圆在另一个圆内，且不相交"
ElseIf d = 0 And r1 = r2 Then
MsgBox "两个圆重合"
Else
' 圆相交，计算交点
' 计算 a 和 h
Dim a As Double, h As Double
a = (r1 ^ 2 - r2 ^ 2 + d ^ 2) / (2 * d)
h = Sqr(r1 ^ 2 - a ^ 2)
' 计算中间点 P0
Dim P0x As Double, P0y As Double
P0x = x1 + a * (x2 - x1) / d
P0y = y1 + a * (y2 - y1) / d
' 计算两个交点
Dim x3_1 As Double, y3_1 As Double
Dim x3_2 As Double, y3_2 As Double
x3_1 = P0x + h * (y2 - y1) / d
y3_1 = P0y - h * (x2 - x1) / d
x3_2 = P0x - h * (y2 - y1) / d
y3_2 = P0y + h * (x2 - x1) / d
' 输出交点坐标
If d = r1 + r2 Or d = Abs(r1 - r2) Then
MsgBox "两个圆相切，交点坐标为：" & vbCrLf & "(" & x3_1 & " , " & y3_1 & ")"
Else
MsgBox "两个圆相交，交点坐标为：" & vbCrLf & "(" & x3_1 & " , " & y3_1 & ")" & vbCrLf & "和" & vbCrLf & "(" & x3_2 & " , " & y3_2 & ")"
End If
End If
End Function
CAD二次开发、插件、代码代写，详情见下方↓
标签：Dim,VBA,End,r1,r2,两圆,Double,交点,CAD From： https://blog.csdn.net/yongshiqq/article/details/142105409