Private Type pointXY
X As Single
Y As Single
End Type
Private Sub calcPolygonArea_test()
Debug.Print calcPolygonArea(100, 100, 100, 300, 300, 400, 400, 250, 300, 0)
Debug.Print calcPolygonArea(300, 300, 300, 100, 0, 0, -100, 400)
Debug.Print calcPolygonArea(50, 150, 200, 50, 350, 150, 350, 250, 250, 320, 200, 250, 150, 350, 100, 250)
Debug.Print calcPolygonArea(100, 100, 300, 100, 400, 300, 100, 300)
End Sub
Function calcPolygonArea(ParamArray vertices()) As Single
Dim t&, aX&, aY&, sX&, sY&, i&, u%, c As Integer, d%
Dim p() As pointXY
u = UBound(vertices) - 1
If u < 4 Or u Mod 2 <> 0 Then
calcPolygonArea = 0
Exit Function
End If
u = (u + 2) / 2
ReDim p(1 To u + 1)
For i = 1 To u
p(i).X = vertices(i * 2 - 2)
p(i).Y = vertices(i * 2 - 1)
Next
p(i).X = vertices(0)
p(i).Y = vertices(1)
For i = 1 To u
c = InOrOut(p, i)
Select Case c
Case 0:
Case -1: t = t + (p(i).X + p(i + 1).X) * (p(i).Y - p(i + 1).Y)
Case 1:
End Select
Next
calcPolygonArea = VBA.Abs(t / 2)
End Function
Function InOrOut(p() As pointXY, ByVal index As Integer) As Integer
'k = length(p)
'Chýìc nãng xác ðiònh viò trí cuÒa ðiêÒm (p0.X, p0.Y) týõng ðôìi
'ðêìn ðýõÌng bao khép kín ðýõòc xác ðiònh bõÒi n ðiêÒm võìi
'toòa ðôò p (i), p (i), i = 1, 2, ..., k
'
'ÐiêÒm 1 phaÒi giôìng võìi ðiêÒm k
'Giá triò hàm ðýõòc traÒ vêÌ ():
'1: ðiêÒm nãÌm bên trong ðýõÌng viêÌn
'-1: ðiêÒm nãÌm ngoài ðýõÌng viêÌn
'0: ðiêÒm nãÌm trên ðýõÌng viêÌn
'************************************************* ********************
Dim kross As Integer, i As Integer
Dim pp As Single, k As Integer, p0 As pointXY
k = UBound(p)
If index > k Or k < 1 Then
InOrOut = -10
Exit Function
End If
p0 = p(index)
'KhõÒi taòo hàm
InOrOut = 0
'KhõÒi taòo kross, môòt biêìn theo doÞi
'bãÌng bao nhiêu lâÌn bán kính thãÒng ngang
'doÌng bãìt ðâÌu taòi (p0.X, p0.Y) và theo chiêÌu dýõng (phía bên tay phaÒi)
'hýõìng truòc x chãòn ðýõÌng bao
'(ÐýõÌng bao có thêÒ có các ðiÒnh võìi góc lõìn hõn 180 ðôò)
kross = 0
'VoÌng qua tâìt caÒ các mãòt cuÒa ðýõÌng viêÌn
For i = 1 To k - 1
'Nêìu caònh giýÞa ðiÒnh i và i + 1 nãÌm hoàn toàn phía trên
'hoãòc thâìp hõn ðiêÒm (p0.X, p0.Y), boÒ qua nó (không có ðiêÒm chãòn)
If (p(i).Y > p0.Y And p(i + 1).Y > p0.Y) Or (p(i).Y < p0.Y And p(i + 1).Y < p0.Y) Then GoTo NextItem
'Nêìu caònh nãÌm ngang, tránh tính toán ðiêÒm chãòn bãÌng nôòi suy
'viÌ seÞ có môòt phép chia cho sôì không
If p(i).Y = p(i + 1).Y Then
'Nó phaÒi ðýõòc xác ðiònh nêìu ðiêÒm (p0.X, p0.Y) nãÌm trên ðoaòn ngang này
If (p(i).X > p0.X And p(i + 1).X > p0.X) Or (p(i).X < p0.X And p(i + 1).X < p0.X) Then GoTo NextItem
'Nêìu không, chúng ta ðaÞ hoàn tâìt!
Exit For
End If
'Tính pp, toòa ðôò cuÒa ðiêÒm mà ðoaòn nôìi võìi
'các caònh i và i + 1 và ðýõÌng thãÒng nãÌm ngang ði qua (p0.X, p0.Y) giao nhau
pp = p(i).X + (p0.Y - p(i).Y) * ((p(i + 1).X - p(i).X) / (p(i + 1).Y - p(i).Y))
'Dâìu cuÒa pp-p0.X xác ðiònh viò trí cuÒa ðiêÒm chãòn so võìi (p0.X, p0.Y)
If pp - p0.X > 0 Then
'Ðánh chãòn õÒ bên phaÒi: bôò ðêìm gia tãng (nhýng chiÒ khi ðiêÒm ðánh chãòn không nói dôìi
'trên ðiÒnh ðâÌu tiên, ðêÒ tránh ðêìm cùng môòt ðiêÒm chãòn hai lâÌn!)
If p0.Y <> p(i).Y Then kross = kross + 1
ElseIf pp - p0.X = 0 Then
Exit For
End If
'Nêìu chôìt chãòn nãÌm õÒ bên trái, không thýòc hiêòn hành ðôòng nào và tiêìp tuòc
NextItem:
Next
'Nêìu sôì ðiêÒm giao nhau là sôì chãÞn, ðiêÒm (p0.X, p0.Y) nãÌm ngoài ðýõÌng bao
'Nêìu nó kyÌ quãòc thiÌ nó nãÌm bên trong
InOrOut = IIf(kross Mod 2 = 0, -1, 1)
End Function
). Khi tìm ra được 4 điểm cực này rồi thì cái thứ tự lần lượt các đỉnh cũng trở nên không khó lắm (đoạn này mới thách thức tý khả năng của bạn nè)
