Sub aa()
Dim pACD As AcadDocument
Dim pRect As New TRectangle
Dim pAngle As Double
Dim pT1, pT2
Set pACD = ThisDrawing
pAngle = Pi * 30 / 180
PrintMessage vbCrLf & "Пусть будет угол " & 30 & " градусов."
PrintMessage vbCrLf & "Первая точка "
pT1 = pACD.Utility.GetPoint
PrintMessage vbCrLf & "Вторая точка "
pT2 = pACD.Utility.GetPoint(pT1)
pRect.InitTTA pT1, pT2, pAngle
pRect.CreateLWPolyLine pACD.ModelSpace
End Sub
Класс TRectangle
'Class TRectangle
Option Explicit
Private mTS(1) As Double, mTE(1) As Double
Private mT(3, 1) As Double
Private Angle As Double, hw As Double, L As Double
Private mTmin(1) As Double, mTmax(1) As Double
Public Sub InitSEW(Tstart, Tend, Width As Double)
Dim pT As Variant
mTS(0) = Tstart(0): mTS(1) = Tstart(1)
mTE(0) = Tend(0): mTE(1) = Tend(1)
Angle = AngleFromXAxis(mTS, mTE)
hw = Width / 2
pT = PolarPoint(mTS, Angle - Pi_2, hw)
mT(0, 0) = pT(0): mT(0, 1) = pT(1)
pT = PolarPoint(mTE, Angle - Pi_2, hw)
mT(1, 0) = pT(0): mT(1, 1) = pT(1)
pT = PolarPoint(mTE, Angle + Pi_2, hw)
mT(2, 0) = pT(0): mT(2, 1) = pT(1)
pT = PolarPoint(mTS, Angle + Pi_2, hw)
mT(3, 0) = pT(0): mT(3, 1) = pT(1)
SearchMinMaxMultyCol mT, 0, mTmin(0), mTmax(0)
SearchMinMaxMultyCol mT, 1, mTmin(1), mTmax(1)
End Sub
Public Sub InitTTA(TLeftBottom, TRightTop, Angle As Double)
Dim pT(1) As Double, L As Double, m As Double, d As Double
Dim t1(1) As Double, t2(1) As Double, t3(1) As Double, t4(1) As Double
PolarPoint TLeftBottom, Angle, 100, pT
L = pT(0) - TLeftBottom(0): m = pT(1) - TLeftBottom(1)
d = -(m * (TRightTop(0) - TLeftBottom(0)) _
- L * (TRightTop(1) - TLeftBottom(1))) _
/ Sqr(L * L + m * m)
If d < 0 Then
PolarPoint TLeftBottom, Angle + Pi_2, d, t1
t4(0) = TLeftBottom(0): t4(1) = TLeftBottom(1)
PolarPoint TRightTop, Angle - Pi_2, d, t3
t2(0) = TRightTop(0): t2(1) = TRightTop(1)
Else
PolarPoint TLeftBottom, Angle + Pi_2, d, t4
t1(0) = TLeftBottom(0): t1(1) = TLeftBottom(1)
PolarPoint TRightTop, Angle - Pi_2, d, t2
t3(0) = TRightTop(0): t3(1) = TRightTop(1)
End If
mT(0, 0) = t1(0): mT(0, 1) = t1(1)
mT(1, 0) = t2(0): mT(1, 1) = t2(1)
mT(2, 0) = t3(0): mT(2, 1) = t3(1)
mT(3, 0) = t4(0): mT(3, 1) = t4(1)
mTS(0) = (t1(0) + t4(0)) / 2: mTS(1) = (t1(1) + t4(1)) / 2
mTE(0) = (t2(0) + t3(0)) / 2: mTE(1) = (t2(1) + t3(1)) / 2
SearchMinMaxMultyCol mT, 0, mTmin(0), mTmax(0)
SearchMinMaxMultyCol mT, 1, mTmin(1), mTmax(1)
hw = Distance(t2, t3) / 2
L = Distance(t1, t2)
End Sub
Public Sub GetBoundingBox(TMin, TMax, Optional DX, Optional DY)
TMin = mTmin: TMax = mTmax
If Not IsMissing(DX) Then DX = mTmax(0) - mTmin(0)
If Not IsMissing(DY) Then DY = mTmax(1) - mTmin(1)
End Sub
Public Function CreateLWPolyLine(acBlock As AcadBlock, Optional CenterLine As Boolean = False) As AcadLWPolyline
Dim pLWP As AcadLWPolyline
Dim pVrtx() As Double
Dim W As Double
If CenterLine Then
ReDim pVrtx(0 To 3)
pVrtx(0) = mTS(0): pVrtx(1) = mTS(1): pVrtx(2) = mTE(0): pVrtx(3) = mTE(1)
Set pLWP = acBlock.AddLightWeightPolyline(pVrtx)
W = 2 * hw
pLWP.SetWidth 0, W, W
Else
ReDim pVrtx(0 To 7)
pVrtx(0) = mT(0, 0): pVrtx(1) = mT(0, 1): pVrtx(2) = mT(1, 0): pVrtx(3) = mT(1, 1)
pVrtx(4) = mT(2, 0): pVrtx(5) = mT(2, 1): pVrtx(6) = mT(3, 0): pVrtx(7) = mT(3, 1)
Set pLWP = acBlock.AddLightWeightPolyline(pVrtx)
pLWP.Closed = True
End If
Set CreateLWPolyLine = pLWP
End Function
Public Property Get startPoint() As Variant
startPoint = mTS
End Property
'Public Property Let StartPoint(ByVal vNewValue As Variant)
'End Property
Public Property Get endPoint() As Variant
endPoint = mTE
End Property
'Public Property Let EndPoint(ByVal vNewValue As Variant)
'End Property
Public Function BorderPoint(Index As Long) As Variant
BorderPoint = Array(mT(Index, 0), mT(Index, 1))
End Function
Public Property Get HalfWidth() As Double
HalfWidth = hw
End Property
'Public Property Let HalfWidth(ByVal vNewValue As Variant)
'End Property
Используемые процедуры:
Public Const Pi = 3.14159265358979
Public Const Pi2 = 6.28318530717959
Public Const Pi_2 = 1.5707963267949
Public Const Pi_3 = 4.71238898038469
Public Const Pi_4 = 0.785398163397448
Public Const Sin_Pi_4 = 0.707106781186548
Public Const Tan_Pi_8 = 0.414213562373095
Public Sub SearchMinMaxMultyCol(ByRef ArrayOfNumbers, ncol As Long, _
ByRef MinVal, ByRef MaxVal)
Dim i As Long, n1 As Long, n2 As Long
n1 = LBound(ArrayOfNumbers, 1): n2 = UBound(ArrayOfNumbers, 1)
MinVal = ArrayOfNumbers(n1, ncol): MaxVal = ArrayOfNumbers(n2, ncol)
For i = n1 + 1 To n2
If MinVal > ArrayOfNumbers(i, ncol) Then MinVal = ArrayOfNumbers(i, ncol)
If MaxVal < ArrayOfNumbers(i, ncol) Then MaxVal = ArrayOfNumbers(i, ncol)
Next i
End Sub
Public Function PolarPoint(ByVal t0 As Variant, ByVal ang As Double, _
ByVal Dist As Double, Optional Result) As Variant
Dim pVal(2) As Double
pVal(0) = t0(0) + Cos(ang) * Dist
pVal(1) = t0(1) + Sin(ang) * Dist
pVal(2) = 0
PolarPoint = pVal
If Not IsMissing(Result) Then
Result(0) = pVal(0)
Result(1) = pVal(1)
End If
End Function
Public Function AngleFromXAxis(t0 As Variant, t1 As Variant)
Dim x As Double, y As Double
x = t1(0) - t0(0): y = t1(1) - t0(1)
If x >= Abs(y) Then
AngleFromXAxis = Atn(y / x)
ElseIf -x >= Abs(y) Then
AngleFromXAxis = Pi + Atn(y / x)
ElseIf y >= Abs(x) Then
AngleFromXAxis = Pi_2 + Atn(-x / y)
Else
AngleFromXAxis = Pi_3 + Atn(-x / y)
End If
End Function
Класс TRectangle можно инициализировать двумя способами: так как ты спрашиваешь - две диагональные точки и угол, или - две противоположные точки и ширина. После этого построить прямоугольник. Построить можно либо контур, либо полилинию с ненулевой шириной сегмента.