随笔- 7 文章- 3 评论- 1 阅读- 1858
VBA计算两个三角形的交叠面积

  1 Public Function crossarea(Rx, Ry, Gx, Gy, Bx, By, RefRx, RefRy, RefGx, RefGy, RefBx, RefBy) As Variant
  2     '色坐标赋值
  3     Dim crossline(1 To 6, 1 To 7) As Double
  4     Dim sortline As Variant
  5     Dim eps As Double
  6     eps = 0.0000000001
  7     
  8     crossline(1, 1) = Rx
  9     crossline(1, 2) = Ry
 10     crossline(1, 3) = Gx
 11     crossline(1, 4) = Gy
 12     
 13     crossline(2, 1) = Gx
 14     crossline(2, 2) = Gy
 15     crossline(2, 3) = Bx
 16     crossline(2, 4) = By
 17     
 18     crossline(3, 1) = Bx
 19     crossline(3, 2) = By
 20     crossline(3, 3) = Rx
 21     crossline(3, 4) = Ry
 22     
 23     crossline(4, 1) = RefRx
 24     crossline(4, 2) = RefRy
 25     crossline(4, 3) = RefGx
 26     crossline(4, 4) = RefGy
 27     
 28     crossline(5, 1) = RefGx
 29     crossline(5, 2) = RefGy
 30     crossline(5, 3) = RefBx
 31     crossline(5, 4) = RefBy
 32     
 33     crossline(6, 1) = RefBx
 34     crossline(6, 2) = RefBy
 35     crossline(6, 3) = RefRx
 36     crossline(6, 4) = RefRy
 37     '计算角度信息，方便排序
 38     For i = 1 To 6
 39         crossline(i, 5) = crossline(i, 3) - crossline(i, 1)
 40         crossline(i, 6) = crossline(i, 4) - crossline(i, 2)
 41         crossline(i, 7) = Application.WorksheetFunction.Atan2(crossline(i, 5), crossline(i, 6)) * 180 / Application.WorksheetFunction.Pi
 42         If (crossline(i, 7) < 0) Then
 43             crossline(i, 7) = crossline(i, 7) + 360
 44         End If
 45     Next
 46     '排序算法
 47     sortline = funPaiXu(crossline, 7) '对直线进行排序
 48     Dim linequeue As Collection '定义line集合
 49     Set linequeue = New Collection
 50     linequeue.Add 1
 51 
 52     '删除重复直线和平行直线
 53     For i = 2 To 6
 54         k = (sortline(i, 1) - sortline(i - 1, 1)) * (sortline(i, 4) - sortline(i - 1, 2)) - (sortline(i, 2) - sortline(i - 1, 2)) * (sortline(i, 3) - sortline(i - 1, 1))
 55         
 56         If crossline(i - 1, 7) = crossline(i, 7) And k < 0 Then
 57             linequeue.Remove (linequeue.Count)
 58         ElseIf crossline(i - 1, 7) = crossline(i, 7) And k >= 0 Then
 59         Else
 60             linequeue.Add i
 61         End If
 62     Next
 63 
 64     '判断直线位置
 65 
 66     'i = linequeue.Count
 67     Dim crosspoint As Variant
 68     Dim allpoint(12, 1) As Double '定义所有交点集合
 69     Dim allfactpoint As Collection
 70     Set allfactpoint = New Collection
 71     i = 2
 72     Do While i < linequeue.Count
 73         crosspoint = Getcrosspoint(sortline(linequeue.Item(i - 1), 1), sortline(linequeue.Item(i - 1), 2), sortline(linequeue.Item(i - 1), 3), sortline(linequeue.Item(i - 1), 4), sortline(linequeue.Item(i), 1), sortline(linequeue.Item(i), 2), sortline(linequeue.Item(i), 3), sortline(linequeue.Item(i), 4))
 74         k = (sortline((linequeue.Item(i + 1)), 1) - crosspoint(0)) * (sortline((linequeue.Item(i + 1)), 4) - crosspoint(1)) - (sortline((linequeue.Item(i + 1)), 2) - crosspoint(1)) * (sortline((linequeue.Item(i + 1)), 3) - crosspoint(0))
 75         allpoint(i, 0) = crosspoint(0)
 76         allpoint(i, 1) = crosspoint(1)
 77         allfactpoint.Add i
 78         If k < eps And crosspoint(2) = 1 Then
 79             linequeue.Remove i
 80             allfactpoint.Remove (allfactpoint.Count)
 81         Else
 82             i = i + 1
 83         End If
 84     Loop
 85     'Dim testa As Double
 86     'testa = linequeue.Count
 87     '计算开头和结尾的相交的情况
 88     k = -1
 89     Do While linequeue.Count > 1 And k < eps
 90         i = allfactpoint.Item(allfactpoint.Count)
 91         crosspoint = Getcrosspoint(sortline(linequeue.Item(linequeue.Count - 1), 1), sortline(linequeue.Item(linequeue.Count - 1), 2), sortline(linequeue.Item(linequeue.Count - 1), 3), sortline(linequeue.Item(linequeue.Count - 1), 4), sortline(linequeue.Item(linequeue.Count), 1), sortline(linequeue.Item(linequeue.Count), 2), sortline(linequeue.Item(linequeue.Count), 3), sortline(linequeue.Item(linequeue.Count), 4))
 92         k = (sortline(linequeue.Item(1), 1) - crosspoint(0)) * (sortline(linequeue.Item(1), 4) - crosspoint(1)) - (sortline(linequeue.Item(1), 2) - crosspoint(1)) * (sortline(linequeue.Item(1), 3) - crosspoint(0))
 93         allpoint(linequeue.Count, 0) = crosspoint(0)
 94         allpoint(linequeue.Count, 1) = crosspoint(1)
 95         allfactpoint.Add (linequeue.Count)
 96         If k < eps And crosspoint(2) = 1 Then
 97             linequeue.Remove (linequeue.Count)
 98             allfactpoint.Remove (allfactpoint.Count)
 99             allfactpoint.Remove (allfactpoint.Count)
100 
101         End If
102     Loop
103     'i = linequeue.Count
104     k = -1
105     Do While linequeue.Count > 1 And k < eps
106         crosspoint = Getcrosspoint(sortline(linequeue.Item(linequeue.Count), 1), sortline(linequeue.Item(linequeue.Count), 2), sortline(linequeue.Item(linequeue.Count), 3), sortline(linequeue.Item(linequeue.Count), 4), sortline(linequeue.Item(1), 1), sortline(linequeue.Item(1), 2), sortline(linequeue.Item(1), 3), sortline(linequeue.Item(1), 4))
107         k = (sortline(linequeue.Item(2), 1) - crosspoint(0)) * (sortline(linequeue.Item(2), 4) - crosspoint(1)) - (sortline(linequeue.Item(2), 2) - crosspoint(1)) * (sortline(linequeue.Item(2), 3) - crosspoint(0))
108         allpoint(1, 0) = crosspoint(0)
109         allpoint(1, 1) = crosspoint(1)
110         allfactpoint.Add 1
111         If k < eps And crosspoint(2) = 1 Then
112             linequeue.Remove 1
113             allfactpoint.Remove (allfactpoint.Count)
114             allfactpoint.Remove 1
115             
116         End If
117         
118     Loop
119     '计算所有的有用的直线
120     Dim a As Integer
121     a = allfactpoint.Count
122     Dim factpoint() As Double
123     ReDim factpoint(a - 1, 1)
124     For i = 0 To a - 1
125         For j = 0 To 1
126             factpoint(i, j) = allpoint(allfactpoint.Item(i + 1), j)
127         Next
128     Next
129     crossarea = Areacal(factpoint)
130 End Function
131 Function Areacal(arr() As Double) As Double
132     Dim a As Long
133     Dim i As Integer
134     a = UBound(arr, 1)
135     Dim sum As Double
136     
137     For i = 0 To a - 1
138     
139         sum = sum + (arr(i, 0) * arr(i + 1, 1) - arr(i + 1, 0) * arr(i, 1))
140     
141     Next
142     
143         sum = (sum + (arr(a, 0) * arr(0, 1) - arr(a, 1) * arr(0, 0))) / 2
144     Areacal = sum
145        
146 End Function
147 '计算直线交点
148 Function Getcrosspoint(x1, y1, x2, y2, x3, y3, x4, y4) As Variant
149 
150     Dim firstline As Variant
151     Dim secondline As Variant
152     Dim m As Double
153     Dim point(2) As Double
154     
155     firstline = GeneralEquation(x1, y1, x2, y2)
156     secondline = GeneralEquation(x3, y3, x4, y4)
157     m = firstline(0) * secondline(1) - firstline(1) * secondline(0)
158     If m = 0 Then
159         point(2) = 0
160     Else
161         point(0) = (secondline(2) * firstline(1) - firstline(2) * secondline(1)) / m
162         point(1) = (firstline(2) * secondline(0) - secondline(2) * firstline(0)) / m
163         point(2) = 1
164     End If
165     Getcrosspoint = point
166     
167 'k = (line6(i, 1) - x) * (line6(i, 4) - y) - (line6(i, 2) - y) * (line6(i, 3) - x)
168 End Function
169 Function GeneralEquation(x1, y1, x2, y2) As Variant
170 '一般是Ax+By+C=0
171     Dim a As Double
172     Dim b As Double
173     Dim C As Double
174     Dim result(2) As Variant
175     result(0) = y2 - y1
176     result(1) = x1 - x2
177     result(2) = x2 * y1 - x1 * y2
178     GeneralEquation = result
179 End Function
180 
181 Sub test()
182     Dim shit As Variant
183     shit = crossarea(Sheet2.Range("G20"), Sheet2.Range("H20"), Sheet2.Range("G21"), Sheet2.Range("H21"), Sheet2.Range("G22"), Sheet2.Range("H22"), 0.64, 0.33, 0.3, 0.6, 0.15, 0.06)
184     Sheet2.Cells(30, 6) = shit
185 '    For i = 0 To 2
186 '        For j = 0 To 1
187 '            Sheet2.Cells(i + 30, j + 3) = shit(i, j)
188 '        Next
189 '    Next
190 
191 End Sub
192 '二维数组根据n列排序,从1开始的数组,输入二维数组和需要排序的列，输出为排序后的数组结果
193 Public Function funPaiXu(arr As Variant, n As Integer)
194 Dim MaxV(7) As Double, i As Integer, j As Integer, a As Integer, b As Integer, C As Integer
195 Dim fuzhi As Integer
196 a = UBound(arr)
197 b = a
198 
199 For i = a To 1 Step -1
200     For fuzhi = 1 To UBound(arr, 2)
201     MaxV(fuzhi) = arr(i, fuzhi)
202     Next
203     'MaxV = Arr(i, n) '取最后一个数
204        
205     For j = 1 To b    '通过循环，将最小数放在本次循环内数组最后
206         If arr(j, n) > MaxV(n) Then   '本函数结果是由大到小排序，如果由小到大，改“<”为“>”
207             For fuzhi = 1 To UBound(arr, 2)
208             MaxV(fuzhi) = arr(j, fuzhi)
209             Next
210             'MaxV = Arr(j, n)
211             For fuzhi = 1 To UBound(arr, 2)
212             arr(j, fuzhi) = arr(i, fuzhi)
213             Next
214             'Arr(j, n) = Arr(i, n)
215             For fuzhi = 1 To UBound(arr, 2)
216             arr(i, fuzhi) = MaxV(fuzhi)
217             Next
218             'Arr(i, n) = MaxV
219         End If
220     Next j
221     b = b - 1    '下次比较截止到数组倒数第二个元素，依次递减
222 Next i
223 funPaiXu = arr
224 End Function