PDA

View Full Version : Point in Polygon



Aussiebear
08-29-2016, 06:20 AM
Within the last couple of days I have been given a variant of the Point in a Polygon and was wondering if anyone can tell me just what it does, Line by Line please?


Public Function PointInPoly(XCoord As Double, YCoord As Double, Polygon As Variant) As Variant
Dim X As Long
Dim NumSidesCrossed As Long
Dim m As Double
Dim b As Double
Dim Poly As Variant
Poly = Polygon
If Not (Poly(LBound(Poly), 1) = Poly(UBound(Poly), 1) And _
Poly(LBound(Poly), 2) = Poly(UBound(Poly), 2)) Then
If TypeOf Application.Caller Is Range Then
PointInPoly = "#UnclosedPolygon!"
Else
Err.Raise 998, , "Polygon Does Not Close!"
End If
Exit Function
ElseIf UBound(Poly, 2) - LBound(Poly, 2) <> 1 Then
If TypeOf Application.Caller Is Range Then
PointInPoly = "#WrongNumberOfCoordinates!"
Else
Err.Raise 999, , "Array Has Wrong Number Of Coordinates!"
End If
Exit Function
End If
For X = LBound(Poly) To UBound(Poly) - 1
If Poly(X, 1) > XCoord Xor Poly(X + 1, 1) > XCoord Then
m = (Poly(X + 1, 2) - Poly(X, 2)) / (Poly(X + 1, 1) - Poly(X, 1))
b = (Poly(X, 2) * Poly(X + 1, 1) - Poly(X, 1) * Poly(X + 1, 2)) / (Poly(X + 1, 1) - Poly(X, 1))
If m * XCoord + b > YCoord Then NumSidesCrossed = NumSidesCrossed + 1
End If
Next
PointInPoly = CBool(NumSidesCrossed Mod 2)
End Function


If I use the function in the following fashion
=If(PointInPolygon($D2,$E2,tblBarcooNorthEast),"Y","") the function fails by raising the error msg #Value. What have I done wrong?

Paul_Hossler
08-29-2016, 06:50 AM
1. Can you post a sample workbook?

2. There are 2 Err.Raise statements, 998 and 999. Which one was raised?

Aussiebear
08-29-2016, 06:52 AM
When I show the calculation steps this is what I see;

=If(PointInPoly($D2,$E2,tblBarcooNorthEast),"Y","")

Step In - Displays
Sheet2!$D$3:$E$7 (Which is correct)

Step Out - Displays
=If(PointInPoly($D2,$E2,tblBarcooNorthEast),"Y","")

Evaluate - Displays
=IF(False,"Y","")

Evaluate -Displays
#Value!

p45cal
08-29-2016, 07:33 AM
It seems to work here.
Apart from possible typo (PointInPolygon v. PointInPoly) I can only think it's to do with the data. Could you post a sample workbook where this is happening as Paul suggested?

Kenneth Hobs
08-29-2016, 11:04 AM
Typically, the first point must be repeated as the last point. It closes the loop if you will.

I do that for the user sometimes when I code for this sort of thing while others just state that as a requirement. It is usually needed for plotting purposes anyway...

Paul_Hossler
08-29-2016, 03:13 PM
Works for me using my data as WS function or when called from VBA

Most likely, it's something in your data or named range



Option Explicit
Sub drv()
MsgBox PointInPoly(Range("A2"), Range("B2"), Range("C2:D6"))

End Sub

Public Function PointInPoly(XCoord As Double, YCoord As Double, Polygon As Variant) As Variant
Dim X As Long
Dim NumSidesCrossed As Long
Dim m As Double
Dim b As Double
Dim Poly As Variant

Poly = Polygon

If Not (Poly(LBound(Poly), 1) = Poly(UBound(Poly), 1) And _
Poly(LBound(Poly), 2) = Poly(UBound(Poly), 2)) Then
If TypeOf Application.Caller Is Range Then
PointInPoly = "#UnclosedPolygon!"
Else
Err.Raise 998, , "Polygon Does Not Close!"
End If
Exit Function

ElseIf UBound(Poly, 2) - LBound(Poly, 2) <> 1 Then
If TypeOf Application.Caller Is Range Then
PointInPoly = "#WrongNumberOfCoordinates!"
Else
Err.Raise 999, , "Array Has Wrong Number Of Coordinates!"
End If
Exit Function
End If

For X = LBound(Poly) To UBound(Poly) - 1
If Poly(X, 1) > XCoord Xor Poly(X + 1, 1) > XCoord Then
m = (Poly(X + 1, 2) - Poly(X, 2)) / (Poly(X + 1, 1) - Poly(X, 1))
b = (Poly(X, 2) * Poly(X + 1, 1) - Poly(X, 1) * Poly(X + 1, 2)) / (Poly(X + 1, 1) - Poly(X, 1))
If m * XCoord + b > YCoord Then NumSidesCrossed = NumSidesCrossed + 1
End If
Next

PointInPoly = CBool(NumSidesCrossed Mod 2)
End Function

Aussiebear
08-29-2016, 03:49 PM
This was the code which I have been using but appears to fail when a GPS mark lies close to a boundary between two polygons. It results in a mark being allocated to two or more polygons. Which then brings mistrust into the results.

Public Function PtInPoly(XCoord As Double, YCoord As Double, Polygon As Variant) As Boolean
Dim X As Long
Dim Y As Long
Dim b As Double
Dim Poly As Variant
Dim NumSidesCrossed As Long
Poly = Polygon
For X = 1 To UBound(Poly) - 1
If Poly(X, 1) > XCoord Xor Poly(X + 1, 1) > XCoord Then
m = (Poly(X + 1, 2) - Poly(X, 2)) / (Poly(X + 1, 1) - Poly(X, 1))
b = (Poly(X, 2) * Poly(X + 1, 1) - Poly(X, 1) * Poly(X + 1, 2)) / (Poly(X + 1, 1) - Poly(X, 1))
If m * XCoord + b > YCoord Then NumSidesCrossed = NumSidesCrossed + 1
End If
Next
PtInPoly = NumSidesCrossed Mod 2
End Function

There are a number of differences between the two codes namely,
1. The working function is declared as a Boolean, whilst the erroring function is as a Variant
2. The erroring function includes data error checking ( check to see if the polygon is a closed loop and, if the array has the correct number of coordinates)
3. The working function has PtInPoly = NumSidesCrossed Mod 2 whilst the erroring function uses PointInPoly = CBool(NumSidesCrossed Mod 2)

@Paul, Neither of those error codes are being raised. The formula fails as outlined in Post #2.

@P45cal, Both PointInPoly & PtInPoly are function Names. I use PointInPoly for the longer code, simply to help me identify which code I was using at the time.

@Kenneth, Some time ago you kindly pointed out that I needed to repeat the first mark, and all my polygons are correct in this manner (Yes, I've checked).

If, =If(PtInPoly($D2,$E2,tblBarcooNorthEast),"Y","") works i.e. produces a "Y" or blank result,
and =If(PointInPoly($D2,$E2,tblBarcooNorthEast),"Y","") doesn't as it errors out as in Post #2.

Paul_Hossler
08-29-2016, 04:26 PM
appears to fail when a GPS mark lies close to a boundary between two polygons. It results in a mark being allocated to two or more polygons. Which then brings mistrust into the results.

I wonder if it might be because the earth is a spheroid and the formula is intended for planes?

Kenneth Hobs
08-29-2016, 05:19 PM
You have probably seen this file before. I just added your routine and named it PtInPoly2() Graphically, it is easier to see. By default, if point is on the polygon, it is not "in" the polygon. Of course then there are floating point issues depending on needed accuracy.

In the thread where I used this, I also looked at shortest distance from polygon. That distance is either the perpendicular line that intersects the segment or point to corner point, not perpendicular.

Aussiebear
08-29-2016, 05:20 PM
I now tend to think its a gremlin in my laptop.....

At 12.45 last night nothing worked, now 10.15am next morning the PointInPoly function works on 43 of the 45 columns. PtinPoly still works on all columns.

Aussiebear
08-29-2016, 05:25 PM
Kenneth, Can I plot my polygons?

Aussiebear
08-29-2016, 05:54 PM
Been foraging and found this. Shapes.AddPolyline - Method (In German so will need a translation)

Syntax
Ausdruck. AddPolyline (SafeArrayOfPoints)

Name: SafeArrayOfPoints

Erforderlich/Optional: Erforderlich

DataType: Variant

Beschreibung: Ein Array von koordinatenpaaren, das die scheitelpunke der Polyline angibt



Dim triArray(1 to 4, 1 to 2) As Single
triArray (1, 1) = 25
triArray(1, 2) = 100
triArray (2, 1) = 100
triArray (2, 2) = 150
triArray (3, 1) = 150
triArray (3, 2) = 50
triArray (4, 1) = 25 'Last point needs to be the same as the first point
triArray (4, 2) = 100
Set MyDocument =Worksheets(1)
MyDocument.Shapes.Addpolyline triArray


What exactly does this do?

Aussiebear
08-29-2016, 06:06 PM
Perhaps even this

Sub FillPentagon()
'this should work for a shape with any number of points, not just a pentagon
'select chart then run this macro
Dim x As Single 'X locations of points
Dim y As Single 'y locations of points
Dim Z As Long ' loop counter
Dim XStart As Double 'left edge of the plot area
Dim YStart As Double ' top edge of the plot area
Dim XScale As Double 'X width divided by x scale
Dim YScale As Double 'Y width divided by y scale
Dim XValues As Variant 'used to hold the xvalues from the xlcategory axis, can't access them directly
Dim YValues As Variant 'used to hold the yvalues from the xlvalue axis, can't access them directly


'ActiveChart.ChartArea.Select
'store the x and y values in the applicable variable so they can be accessed individually in the loop
XValues = ActiveChart.SeriesCollection(1).XValues
YValues = ActiveChart.SeriesCollection(1).Values

'set the x and y scale
With ActiveChart.Axes(xlCategory)
XScale = ActiveChart.PlotArea.InsideWidth / (.MaximumScale - .MinimumScale)
End With
With ActiveChart.Axes(xlValue)
YScale = ActiveChart.PlotArea.InsideHeight / (.MaximumScale - .MinimumScale)
End With

'set the x and y start
XStart = ActiveChart.PlotArea.InsideLeft
YStart = ActiveChart.PlotArea.InsideTop

'set the x and y value for the first point in the series
x = XStart + (XValues(1) - ActiveChart.Axes(xlCategory).MinimumScale) * XScale
y = YStart + (ActiveChart.Axes(xlValue).MaximumScale - YValues(1)) * YScale

'draw freeform shape on chart
With ActiveChart.Shapes.BuildFreeform(msoEditingAuto, x, y)
'add a node for each point except the first
For Z = 2 To UBound(XValues)
x = XStart + (XValues(Z) - ActiveChart.Axes(xlCategory).MinimumScale) * XScale
y = YStart + (ActiveChart.Axes(xlValue).MaximumScale - YValues(Z)) * YScale
.AddNodes msoSegmentLine, msoEditingAuto, x, y
Next
'convert the freeform to a shape object
.ConvertToShape.Select

End With
'set background color
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid


Set XValues = Nothing
Set YValues = Nothing
End Sub

Kenneth Hobs
08-29-2016, 06:14 PM
Sure, see my file. For series x range it plots more than needed: =Sheet1!$K$5:$K$24
for series y range: =Sheet1!$L$5:$L$24

You can use named ranges too.

I have not used addpolyline as a normal series works for me. It may be handy though.