Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
End Sub
'四边形点撞击判断 切忌只适用在北半球，东半部
Public Function RectangleCollision(ByVal P1 As LongitudeLatitudeType, ByVal P2 As LongitudeLatitudeType, ByVal P3 As LongitudeLatitudeType, ByVal P4 As LongitudeLatitudeType, ByVal Point As LongitudeLatitudeType) As Boolean
Dim LT, LB, RT, RB As New LongitudeLatitudeType 'L:Left, R:Right, T:Top, B:Bottom
Dim temp(3), swap As LongitudeLatitudeType
Dim i, j As Short
Dim m, result As Double '求斜率及点带入的结果
temp(0) = P1
temp(1) = P2
temp(2) = P3
temp(3) = P4
'先用泡沫排序法，将纬度由高到低排序
For i = 0 To 3
For j = i + 1 To 3
If CDbl(temp(i).Latitude) < CDbl(temp(j).Latitude) Then
swap = temp(i)
temp(i) = temp(j)
temp(j) = swap
End If
Next
Next
'比对最上面的经度
If CDbl(temp(0).Longitude) < CDbl(temp(1).Longitude) Then
LT = temp(0)
RT = temp(1)
Else
LT = temp(1)
RT = temp(0)
End If
'比对最下面的经度
If CDbl(temp(2).Longitude) < CDbl(temp(3).Longitude) Then
LB = temp(2)
RB = temp(3)
Else
LB = temp(3)
RB = temp(2)
End If
'比对象限
'求是否在LT→RT的下方
LineFunction(CDbl(LT.Longitude), CDbl(LT.Latitude), CDbl(RT.Longitude), CDbl(RT.Latitude), CDbl(Point.Longitude), CDbl(Point.Latitude), m, result)
If result < 0 Then
Return False
End If
'求是否在LB→RB的上方
LineFunction(CDbl(LB.Longitude), CDbl(LB.Latitude), CDbl(RB.Longitude), CDbl(RB.Latitude), CDbl(Point.Longitude), CDbl(Point.Latitude), m, result)
If result > 0 Then
Return False
End If
'求是否在RT→RB的左方
If (RT.Longitude = RB.Longitude And Point.Longitude > RT.Longitude) Then '判断当直线时，判断左右边
Return False
End If
LineFunction(CDbl(RT.Longitude), CDbl(RT.Latitude), CDbl(RB.Longitude), CDbl(RB.Latitude), CDbl(Point.Longitude), CDbl(Point.Latitude), m, result)
If (result * m) > 0 Then
Return False
End If
'求是否在LT→LB的右方
If (LT.Longitude = LB.Longitude And Point.Longitude < LT.Longitude) Then '判断当直线时，判断左右边
Return False
End If
LineFunction(CDbl(LT.Longitude), CDbl(LT.Latitude), CDbl(LB.Longitude), CDbl(LB.Latitude), CDbl(Point.Longitude), CDbl(Point.Latitude), m, result)
If (result * m) < 0 Then
Return False
End If
Return True
End Function
Public Sub LineFunction(ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double, ByVal Point_X As Double, ByVal Point_Y As Double, ByRef Slope As Double, ByRef Result As Double)
Slope = (y1 - y2) / (x1 - x2) '斜率
Result = (Slope * Point_X) - (Slope * x1) + y1 - Point_Y '直线方程式，将点带入
'若Result < 0 则表示点在直线上方，Slope > 0 在左边，Slope < 0 在右边
'若Result > 0 则表示点在直线下方，Slope > 0 在右边，Slope < 0 在左边
'切忌，点至点的方向会影响左右边判断
End Sub
'用于测试是否撞击
Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click
Dim p1, p2, p3, p4, pd As New LongitudeLatitudeType
p1.Latitude = "6011.520"
p1.N_S_Indicator = "N"
p1.Longitude = "13958.080"
p1.E_W_Indicator = "E"
p2.Latitude = "5954.240"
p2.N_S_Indicator = "N"
p2.Longitude = "13001.920"
p2.E_W_Indicator = "E"
p3.Latitude = "4958.080"
p3.N_S_Indicator = "N"
p3.Longitude = "13958.080"
p3.E_W_Indicator = "E"
p4.Latitude = "4949.440"
p4.N_S_Indicator = "N"
p4.Longitude = "13001.920"
p4.E_W_Indicator = "E"
'在区域内的点
'pd.Latitude = "5517.760"
'pd.N_S_Indicator = "N"
'pd.Longitude = "13521.600"
'pd.E_W_Indicator = "E"
'不在区域内的点
pd.Latitude = "5945.600"
pd.N_S_Indicator = "N"
pd.Longitude = "12232.640"
pd.E_W_Indicator = "E"
If RectangleCollision(p1, p2, p3, p4, pd) Then '用于判断是否撞击
'只有当isReceive = false才会进入传送动作，该区域的动作只会执行一次
MsgBox("已经撞击")
Else
MsgBox("未撞击")
End If
End Sub
End Class