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
浙公网安备 33010602011771号