Sub Plo4()
'Посчитать площадь м/у полилиниями по 4 точкам. Или по 3м, разделив их диагональю
'По 4м получается пропепеллер и пло не совсем та. Нужно вычислять перпендикуляр,....
'Разделив на 2 треугольника получим более простой и точный расчет.
'Главное - правильная сортировка пар горизонталей.
'Предпологаем, что по Z все получится, иначе можно использовать трангуляцию.
'Сортируем и обрабатываем пары.
Dim elem As Object
Dim SelSet As AcadSelectionSet
Dim nS As Integer
Dim i As Integer, j As Integer
'Dim p1(0 To 3) As Double, p2 As Double 'координаты пар горизонталей
Dim p1 As Variant, p2 As Variant
Dim pp(0 To 8) As Double 'массив точек треугольника
Dim S As Double, p As Double
Dim sumS As Double
'Dim lin3 As Acad3DPolyline
'Dim p3(0 To 5) As Double
Dim pntN(0 To 2) As Double
Dim pntK(0 To 2) As Double
Dim l3 As Acad3DPolyline
Dim ot3 As AcadLine
On Error Resume Next
ThisDrawing.SelectionSets.Item("mySS").Delete
Set SelSet = ThisDrawing.SelectionSets.Add("mySS")
Set SelSet = ThisDrawing.ActiveSelectionSet
On Error GoTo 0
'Set SelSet = ThisDrawing.ActiveSelectionSet
nS = SelSet.Count
'Пока считаем, что все полилинии. И сортировка как надо. Потом добавим массив отсортированных объектов плолилиний
For j = 0 To nS - 2
i = i + 1
p1 = SelSet.Item(j).Coordinates
p2 = SelSet.Item(j + 1).Coordinates
If Abs(p1(0) - p2(0)) > Abs(p1(0) - p2(2)) Then
pntN(0) = p2(0)
pntN(1) = p2(1)
p2(0) = p2(2)
p2(1) = p2(3)
p2(2) = pntN(0)
p2(3) = pntN(1)
End If
pp(0) = p1(0) 'т1 x
pp(1) = p1(1) 'т1 y
pp(2) = SelSet.Item(j).Elevation 'т1 z
pp(3) = p1(2) 'т2 x
pp(4) = p1(3) 'т2 y
pp(5) = pp(2) 'т2 z
pp(6) = p2(0) 'т3 x
pp(7) = p2(1) 'т3 y
pp(8) = SelSet.Item(j + 1).Elevation 'т3 z
If 1 = 2 Then
Set l3 = ThisDrawing.ModelSpace.Add3DPoly(pp)
l3.color = acGreen
End If
pntN(0) = pp(3): pntN(1) = pp(4): pntN(2) = pp(5)
GoSub Perimetr
sumS = sumS + S
'Второй треугольник
pp(0) = p2(0) 'т1/2 x
pp(1) = p2(1) 'т2/2 y
pp(2) = SelSet.Item(j + 1).Elevation 'т1/2 z
pp(3) = p2(2) 'т2/2 x
pp(4) = p2(3) 'т2/2 y
pp(5) = pp(2) 'т2/2 z
pp(6) = p1(2) 'т3/2 x
pp(7) = p1(3) 'т3/2 y
pp(8) = SelSet.Item(j).Elevation 'т3/2 z
If 1 = 2 Then
Set l3 = ThisDrawing.ModelSpace.Add3DPoly(pp)
l3.color = acBlue
End If
GoSub Perimetr
sumS = sumS + S
If 1 = 1 Then
pntK(0) = pp(0): pntK(1) = pp(1): pntK(2) = pp(5)
Set ot3 = ThisDrawing.ModelSpace.AddLine(pntN, pntK)
ot3.color = acCyan
End If
Next
sumS = (Round(sumS, 0))
MsgBox (i & " трапеций(я). Площадь =" & sumS)
Exit Sub
Perimetr:
'S = p · (p - a) · (p - b) · (p - c) p-полупериметр
a = (p2(0) - pp(3)) ^ 2 + (pp(1) - pp(4)) ^ 2 + (pp(2) - pp(5)) ^ 2
a = Sqr(a)
b = (pp(3) - pp(6)) ^ 2 + (pp(4) - pp(7)) ^ 2 + (pp(5) - pp(8)) ^ 2
b = Sqr(b)
c = (pp(6) - pp(0)) ^ 2 + (pp(7) - pp(1)) ^ 2 + (pp(8) - pp(2)) ^ 2
c = Sqr(c)
p = (a + b + c) / 2
S = p * (p - a) * (p - b) * (p - c)
S = Sqr(S)
Return
End Sub