All pastes #509341 Raw Edit

hy

public text v1 · immutable
·published 2007-05-25 12:23 UTC
rendered paste body
This all goes in the modMisc module:

put these at the top:

Public Type COORD
    x As Double
    y As Double
End Type
Public Type typeAreas
    Name As String
    VectorString As String
End Type

Public Areas() As typeAreas

-----------------------------------
these functions belong in modMisc:


Public Function GetArea(fX, fY) As String
Dim iI As Integer, myPointArray() As COORD
For iI = LBound(Areas) To UBound(Areas)
    MakePointArray Areas(iI).VectorString, myPointArray
    If PointInConvexPolygon(fX, fY, myPointArray) = True Then
        GetArea = Areas(iI).Name
        Exit Function
    End If
Next iI
GetArea = "Unknown"
End Function
Public Function MakePointArray(sPoints As String, ByRef pPointArray() As COORD) As Boolean
Dim pArray() As String, j As Integer, iInt As Integer, iTotalPoints As Integer
iInt = 0
Debug.Print "Orignal Points: " & sPoints
pArray = Split(sPoints, ",")

If ((UBound(pArray) + 1) Mod 2) = 0 Then 'even number
    iTotalPoints = (UBound(pArray) + 1) / 2
    ReDim pPointArray(iTotalPoints - 1)
    For j = 0 To iTotalPoints - 1
        pPointArray(j).x = pArray(iInt)
        pPointArray(j).y = pArray(iInt + 1)
        iInt = iInt + 2
        Debug.Print "Pair " & j + 1 & "/" & iTotalPoints & ": <" & pPointArray(j).x & ", " & pPointArray(j).y & ">"
    Next j
    MakePointArray = True
Else
    MakePointArray = False
End If
End Function
Function PointInConvexPolygon(x, y, pp() As COORD) As Boolean

    Dim test As Boolean, resultpositive As Boolean, i As Integer, res As Double

    For i = 0 To UBound(pp) - 1
        res = (pp(i + 1).x * y) - (pp(i + 1).y * x) - (pp(i).x * y) + (pp(i).y * x) _
        + (pp(i).x * pp(i + 1).y) - (pp(i).y * pp(i + 1).x)


        If i = 0 Then
            If res > 0 Then resultpositive = True
        Else
            If res > 0 Then test = True Else test = False
            If test <> resultpositive Then Exit Function
        End If

    Next

    PointInConvexPolygon = True
End Function

------------------------------------------

At the moment I just have a button that loads the areas in from a text file when clicked, but you could easily make this a command or make it do it in Form_Load:

Private Sub cmdLoadAreas_Click()

ReDim Areas(0)
Dim tmpInt As Integer: tmpInt = 0
Dim tmpString() As String
    MyFile = App.Path & "/areas.txt"
    Open MyFile For Input As #1

    Do Until EOF(1)
        ReDim Preserve Areas(tmpInt)
        Line Input #1, one$ ', two$
        tmpString = Split(one$, "=")
        Areas(tmpInt).VectorString = tmpString(0)
        Areas(tmpInt).Name = tmpString(1)
        
        tmpInt = tmpInt + 1
    Loop

    Close #1
    
End Sub


here is my area command code so you can see how it's used:

Case "area"
    SendChat players(tmpID).Name & "'s location: " & GetArea(players(tmpID).xCoords, players(tmpID).yCoords)