Dawno, dawno, dawno temu napisałem serię małych makr w VBA, które działały pod AutoCad-em. Niestety dostępu do tego programu już nie mam, aczkolwiek pozostały mi właśnie te makra napisane przeze mnie. Poniżej zamieszczam funkcję i makro, które umożliwiają automatyczne wygenerowanie kątownika o określonych wymiarach.
Rys. 1
Profil kątownika rysowanego przez makro i funkcję VBA.
Opis oznaczeń:
L1, L2 - długości ramion kątownika;
R1, R2, R3 - promienie zaokrąglenia kątownika;
Z1, Z2 - zbieżności ramion kątownika.
Sam kod skryptu VBA ma postać następującą:
Sub MKatownik()
Dim R(2) As Double
R(0) = InputBox("Podaj wartość promienia pierwszego ramienia kątownika:", "Promień", 5, 1000, 1000, "", 0)
R(1) = InputBox("Podaj wartość promienia drugiego ramienia kątownika:", "Promień", 5, 1000, 1000, "", 0)
R(2) = InputBox("Podaj wartość promienia wewnętrznego kątownika:", "Promień", 5, 1000, 1000, "", 0)
Katownik InputBox("Podaj długość pierwszego ramienia kątownika: ", "Długość 1", 40, 1000, 1000, "", 0), InputBox("Podaj długość drugiego ramienia kątownika: ", "Długość 2", 40, 1000, 1000, "", 0), R, InputBox("Podaj wartość zbieżności pierwszego ramienia kątownika: ", "Zbieznosc 1", 0.05, 1000, 1000, "", 0), InputBox("Podaj wartość zbieżności drugiego ramienia kątownika: ", "Zbieznosc 2", 0.05, 1000, 1000, "", 0), InputBox("Podaj położenie względem osi X: ", "X", 0, 1000, 1000, "", 0), InputBox("Podaj położenie względem osi Y: ", "Y", 0, 1000, 1000, "", 0), InputBox("Podaj położenie względem osi Z: ", "Z", 0, 1000, 1000, "", 0), InputBox("Długość wyciągnięcia: ", "L", 100, 1000, 1000, "", 0)
End Sub
Function Katownik(l1 As Double, l2 As Double, R, Zbieznosc1 As Double, Zbieznosc2 As Double, X As Double, Y As Double, Z As Double, Dlugosc As Double)
Dim c(5) As AcadEntity
Dim XYZ(8) As Double
XYZ(0) = X: XYZ(1) = Y: XYZ(2) = Z
XYZ(3) = X: XYZ(4) = l1 + Y: XYZ(5) = Z
XYZ(6) = l2 + X: XYZ(7) = l1 + Y: XYZ(8) = Z
Set c(0) = ThisDrawing.ModelSpace.Add3DPoly(XYZ)
Dim XYZ2(2) As Double
XYZ2(0) = X: XYZ2(1) = R(0) + Y: XYZ2(2) = Z
Dim PI As Double, StartAngle As Double, EndAngle As Double
PI = 3.141592654
StartAngle = 270 * PI / 180
EndAngle = -Atn(Zbieznosc1)
Set c(1) = ThisDrawing.ModelSpace.AddArc(XYZ2, R(0), StartAngle, EndAngle)
XYZ2(0) = l2 - R(1) + X: XYZ2(1) = l1 + Y: XYZ2(2) = Z
StartAngle = 3 * PI / 2 + Atn(Zbieznosc2)
EndAngle = 0
Set c(2) = ThisDrawing.ModelSpace.AddArc(XYZ2, R(1), StartAngle, EndAngle)
Dim Poczatek1(2) As Double, Koniec1(2) As Double, Poczatek2(2) As Double, Koniec2(2) As Double, L(2) As Double, Wyznacznik As Double, Beta(1) As Double
Poczatek1(0) = R(0) * Cos(Atn(Zbieznosc1)) + X: Poczatek1(1) = R(0) - R(0) * Sin(Atn(Zbieznosc1)) + Y: Poczatek1(2) = Z
Poczatek2(0) = l2 - R(1) + R(1) * Sin(Atn(Zbieznosc2)) + X: Poczatek2(1) = l1 - R(1) * Cos(Atn(Zbieznosc2)) + Y: Poczatek2(2) = Z
Wyznacznik = Cos(Atn(Zbieznosc1)) * Cos(Atn(Zbieznosc2)) - Sin(Atn(Zbieznosc2)) * Sin(Atn(Zbieznosc1))
Beta(0) = PI / 2 - Atn(Zbieznosc1) - Atn(Zbieznosc2)
Beta(1) = PI - Beta(0)
L(2) = ((2 * R(2) ^ 2 - 2 * R(2) ^ 2 * Cos(Beta(0))) / (2 - 2 * Cos(Beta(1)))) ^ 0.5
L(0) = ((Poczatek2(1) - Poczatek1(1)) * Cos(Atn(Zbieznosc2)) - (Poczatek2(0) - Poczatek1(0)) * Sin(Atn(Zbieznosc2))) / Wyznacznik - L(2)
L(1) = ((Poczatek2(0) - Poczatek1(0)) * Cos(Atn(Zbieznosc1)) - Sin(Atn(Zbieznosc1)) * (Poczatek2(1) - Poczatek1(1))) / Wyznacznik - L(2)
Koniec1(0) = Poczatek1(0) + L(0) * Sin(Atn(Zbieznosc1)): Koniec1(1) = Poczatek1(1) + L(0) * Cos(Atn(Zbieznosc1)): Koniec1(2) = Z
Koniec2(0) = Poczatek2(0) - L(1) * Cos(Atn(Zbieznosc2)): Koniec2(1) = Poczatek2(1) - L(1) * Sin(Atn(Zbieznosc2)): Koniec2(2) = Z
Set c(3) = ThisDrawing.ModelSpace.AddLine(Poczatek1, Koniec1)
Set c(4) = ThisDrawing.ModelSpace.AddLine(Poczatek2, Koniec2)
XYZ2(0) = Koniec1(0) + R(2) * Cos(Atn(Zbieznosc1)): XYZ2(1) = Koniec1(1) - R(2) * Sin(Atn(Zbieznosc1)): XYZ2(2) = Z
StartAngle = PI - Atn(Zbieznosc1) - Beta(0): EndAngle = PI - Atn(Zbieznosc1)
Set c(5) = ThisDrawing.ModelSpace.AddArc(XYZ2, R(2), StartAngle, EndAngle)
Dim Powierzchnia As Variant
Powierzchnia = ThisDrawing.ModelSpace.AddRegion(c)
Dim solidObj As Acad3DSolid
Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolid(Powierzchnia(0), Dlugosc, 0)
For i = 0 To 5
c(i).Delete
Next i
End Function
