> Alexander Larionov
Забыл про этот топик...
Вот решение
Option Explicit
Sub DrawTangent()
Dim oEnt As AcadEntity
Dim oCirc1 As AcadCircle, oCirc2 As AcadCircle
Dim oLine1 As AcadLine, oLine2 As AcadLine
Dim varPt As Variant
Dim Rad1 As Double, Rad2 As Double
Dim dblRad1 As Double, dblRad2 As Double
Dim dblAng1 As Double, dblAng2 As Double, dirAng As Double
Dim centPt1 As Variant, centPt2 As Variant
Dim tangPt1() As Double, tangPt2() As Double
Dim pi As Double, dblDis As Double
pi = Atn(1#) * 4
ThisDrawing.Utility.GetEntity oEnt, varPt, vbCrLf & "Select the first circle"
If TypeOf oEnt Is AcadCircle Then
Set oCirc1 = oEnt
End If
ThisDrawing.Utility.GetEntity oEnt, varPt, vbCrLf & "Select the second circle"
If TypeOf oEnt Is AcadCircle Then
Set oCirc2 = oEnt
End If
centPt1 = oCirc1.Center
centPt2 = oCirc2.Center
dblAng1 = ThisDrawing.Utility.AngleFromXAxis(centPt1, centPt2)
dirAng = dblAng1
Rad1 = oCirc1.Radius
Rad2 = oCirc2.Radius
dblDis = Get_Distance(centPt1, centPt2)
If Rad1 > Rad2 Then
dblRad1 = Rad1
dblRad2 = Rad2
ElseIf Rad1 < Rad2 Then
dblAng1 = dblAng1 - pi
dblRad1 = Rad2
dblRad2 = Rad1
End If
If Rad1 <> Rad2 Then
dblAng2 = Atn((Sqr(dblDis ^ 2 - (dblRad1 - dblRad2) ^ 2)) / (dblRad1 - dblRad2))
dblAng1 = dblAng1 + dblAng2
Else
dblAng1 = dblAng1 + pi / 2
End If
With ThisDrawing.Utility
tangPt1 = .PolarPoint(centPt1, dblAng1, Rad1)
tangPt2 = .PolarPoint(centPt2, dblAng1, Rad2)
End With
ThisDrawing.ModelSpace.AddLine centPt1, centPt2
Set oLine1 = ThisDrawing.ModelSpace.AddLine(tangPt1, tangPt2)
oLine1.Mirror centPt1, centPt2
Set oLine2 = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
oLine1.color = acRed
oLine2.color = acRed
Dim fstDis As Double, sndDis As Double
Dim Kat1 As Double, dblAng As Double, dblAngA As Double
fstDis = dblDis * Rad1 / (Rad2 + Rad1)
Kat1 = Sqr(Abs(fstDis ^ 2 - Rad1 ^ 2))
dblAngA = Atn(Kat1 / Rad1)
dblAng = dirAng + dblAngA
With ThisDrawing.Utility
tangPt1 = .PolarPoint(centPt1, dblAng, Rad1)
tangPt2 = .PolarPoint(centPt2, dirAng + pi + dblAngA, Rad2)
End With
Set oLine1 = ThisDrawing.ModelSpace.AddLine(tangPt1, tangPt2)
oLine1.Mirror centPt1, centPt2
Set oLine2 = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
oLine1.color = acMagenta
oLine2.color = acMagenta
End Sub
Public Function Get_Distance(fPoint As Variant, sPoint As Variant) As Double
Dim x1 As Double, x2 As Double
Dim y1 As Double, y2 As Double
Dim z1 As Double, z2 As Double
Dim cDist As Double
x1 = fPoint(0): y1 = fPoint(1): z1 = fPoint(2)
x2 = sPoint(0): y2 = sPoint(1): z2 = sPoint(2)
cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
Get_Distance = cDist
End Function
~'J'~