The BisectByAngle code cuts a polygon using a ratio (between 0 and 1) and an angle in radian (between 0 and 2PI). The ratio and the angle determine how the polygon will be cut.
How to use
- Use this function into VBA or VB6
'*************************************************************************
'* NAME : BisectByAngle
'* DESCRIPTION : Bisect cut (using proportion) the input polygon using the input angle.
'* The start location of the cutting line is not guaranteed but the angle is.
'* The algorithm goes like this : Take the input polygon, cut it using different lines (all lines have langle as direction)
'* until it satisfies the precision condition.
'* NOTE : Returns a geometry bag with 2 polygons in it.
'* PARAMETERS :
'* - pInPolygon: The input polygon
'* - dBisectRatio : The ratio to achieve between the left and the right
'* or the opposite depending on the bleft parameter
'* - lAngle: The angle at which the polygon has to be cut. The angle is 0 Rad on the XAxis
'* - bLeft: Determines if the left or the right polygon as to meet the ratio
'* - dPrecision: The precision which corresponds to the level at which the
'* areas have to meet the input ratio.
'* USAGE EXAMPLE : Set pGeoBag = modBisectByAngle.BisectByAngle(pPolygon, 0.9, PI/2, False, 0.0000001)
'*************************************************************************
Public Function BisectByAngle(pInPolygon As IPolygon, dBisectRatio As Double, lAngle As Double, bLeft As Boolean, Optional dPrecision As Double = 0.1) As IGeometryBag
Dim dpi As Double, bHor As Boolean, dAngleTemp As Double, pEnv As IEnvelope, pFullArea As IArea
Dim dFullArea As Double, pMinLine As ILine, pMaxLine As ILine, pBagBaseLine As IGeometryCollection
Dim pHalfLine As ILine, pTopo As ITopologicalOperator, pCutter As ISegmentCollection, pLeft As IPolygon
Dim pRight As IPolygon, dRatio As Double, bGoLeft As Boolean, lIter As Long, lMaxIteration As Long
Dim dARight As Double, pARight As IArea, dALeft As Double, pALeft As IArea, pGeocoll As IGeometryCollection
Dim pa0 As IArea, pa1 As IArea, pgCutter As IGeometry, pgOut As IGeometry, prel As IRelationalOperator
Dim ptopoclip As ITopologicalOperator, ppolenv As IEnvelope
On Error GoTo errhand
dpi = Atn(1) * 4 'Value of PI
If pInPolygon Is Nothing Then
Set BisectByAngle = Nothing
MsgBox "Please Enter a valid polygon!"
Exit Function
End If
If pInPolygon.IsEmpty Then
MsgBox "Please Enter a valid polygon!"
Set BisectByAngle = Nothing
Exit Function
End If
'Check if the angle is between 0 and 2PI
If Not (0 <= lAngle) Or Not (lAngle <= (2 * dpi)) Then
Set BisectByAngle = Nothing
MsgBox "Enter an angle between 0 and 2PI Radian"
Exit Function
End If
'Check if the angle is 0
If lAngle = 0 Or lAngle = 2 * dpi Or lAngle = -2 * dpi Then bHor = True
'If input angle is larger than PI then take the corresponding angle in opposite quadrant
If lAngle > dpi Then
dAngleTemp = lAngle
lAngle = - dpi + dAngleTemp
End If
'Check if the polygon as less than two exterior rings, cannot handle more than that
If pInPolygon.ExteriorRingCount > 1 Then
MsgBox "Select a polygon with less than two exterior rings"
Set BisectByAngle = Nothing
Exit Function
End If
Set pEnv = pInPolygon.Envelope 'Get polygon envelope
Set pFullArea = pInPolygon
'Get the area of the polygon
dFullArea = pFullArea.Area
'Create the baselines, the baselines are used as start points in the iterative process.
Set pBagBaseLine = createBaseLineByAngle(pEnv, lAngle, bHor)
Set pMinLine = pBagBaseLine.Geometry(0) 'Get the minline
Set pMaxLine = pBagBaseLine.Geometry(1) 'Get the maxline
lMaxIteration = 1000 'That value could be modified
'Reverse the ratio if not bleft = true
If Not bLeft Then dBisectRatio = 1 - dBisectRatio
Do While Not dRatio = dBisectRatio
lIter = lIter + 1
'Safety check to avoind infinite loop
If lIter = lMaxIteration Then
MsgBox "Cannot determine the bisection !"
Set BisectByAngle = Nothing
Exit Function
End If
'Create the line in the middle of the min and max lines
Set pHalfLine = createHalfLineByAngle(pMinLine, pMaxLine)
'Wrap the created line into a polyline to cut the polygon
Set pCutter = New Polyline
Set pgCutter = pCutter
Set pgCutter.SpatialReference = pInPolygon.SpatialReference 'Define the spatial reference
pCutter.AddSegment pHalfLine
Set pTopo = pInPolygon
Set prel = pTopo
Set ptopoclip = pCutter
Set ppolenv = pInPolygon.Envelope
ppolenv.Expand 1.01, 1.01, True
ptopoclip.Clip ppolenv 'Clip the cutter
If prel.Crosses(pCutter) Then 'Make sure the cutter crosses the polylgon
pTopo.Cut pCutter, pLeft, pRight 'Cut the polygon
If pLeft Is Nothing Or pRight Is Nothing Then
Set BisectByAngle = Nothing
Exit Function
End If
If pLeft.IsEmpty Or pRight.IsEmpty Then
Set BisectByAngle = Nothing
Exit Function
End If
Set pALeft = pLeft
dALeft = pALeft.Area
dRatio = dALeft / dFullArea
Else 'When the cutter doesn't crosse the polygon define the ratio
If dBisectRatio > 0.5 Then 'To make sure the min and max line are determined correctly
dRatio = 1
Else
dRatio = 0
End If
End If
'Check if the cut polygons meet the precision
If Abs(dRatio - dBisectRatio) < dPrecision Then Exit Do
If dRatio < dBisectRatio Then
Set pMinLine = pHalfLine
Else
Set pMaxLine = pHalfLine
End If
Loop
'Create the output geometry bag
Set pGeocoll = New GeometryBag
Set pgOut = pGeocoll
Set pgOut.SpatialReference = pInPolygon.SpatialReference
pGeocoll.AddGeometry pLeft
pGeocoll.AddGeometry pRight
Set pa0 = pLeft
Set pa1 = pRight
If Round(Abs((pa0.Area + pa1.Area) - dFullArea), 10) > Round(dPrecision, 10) Then
MsgBox "Cannot precisely determine the bisection, reduce the precision!"
Set BisectByAngle = Nothing
Exit Function
End If
Set BisectByAngle = pGeocoll
Exit Function
errhand:
MsgBox Err.Description
End Function
'*************************************************************************
'* NAME : createHalfLineByAngle
'* DESCRIPTION : Create a line in the middle of the input lines
'* NOTE : Returns a line
'*************************************************************************
Private Function createHalfLineByAngle(pMinLine As ILine, pMaxLine As ILine) As ILine
On Error GoTo errhand
Dim pline As ILine, pT0 As IPoint, pT1 As IPoint
Set pline = New esriGeometry.Line
Set pT0 = New esriGeometry.Point
Set pT1 = New esriGeometry.Point
pT0.PutCoords (pMinLine.FromPoint.X + pMaxLine.FromPoint.X) / 2, (pMinLine.FromPoint.Y + pMaxLine.FromPoint.Y) / 2
pT1.PutCoords (pMinLine.ToPoint.X + pMaxLine.ToPoint.X) / 2, (pMinLine.ToPoint.Y + pMaxLine.ToPoint.Y) / 2
pline.PutCoords pT0, pT1
Set createHalfLineByAngle = pline
Exit Function
errhand:
Debug.Print Err.Description
End Function
'*************************************************************************
'* NAME : createBaseLineByAngle
'* DESCRIPTION : Create the baselines for the iterative bisection process.
'* NOTE : Returns a geometry bag with 2 lines in it
'*************************************************************************
Private Function createBaseLineByAngle(pEnv As IEnvelope, lAngle As Double, bHor As Boolean) As IGeometryBag
Dim dpi As Double, pMinLine As ILine, pMaxLine As ILine, pT1Max As IPoint
Dim pT2Max As IPoint, pT1Min As IPoint, pT2Min As IPoint, pConspT1Min As IConstructPoint
Dim pLftBaseline As ILine, pLftpb0 As IPoint, pLftpb1 As IPoint, pConspT2Max As IConstructPoint
Dim pGeocoll As IGeometryCollection, pmidpoint0 As IConstructPoint, ptmid0 As IPoint
Dim dx0 As Double, dy0 As Double, ptr0 As ITransform2D, pmidpoint1 As IConstructPoint
Dim ptmid1 As IPoint, dx1 As Double, dy1 As Double, ptr1 As ITransform2D
On Error GoTo errhand
dpi = Atn(1) * 4
If bHor Then
'If the input angle is 0 the maxline and min lines
'are equals to the edges of the envelope
Set pMinLine = New esriGeometry.Line
Set pMaxLine = New esriGeometry.Line
Set pT1Max = New esriGeometry.Point
Set pT2Max = New esriGeometry.Point
Set pT1Min = New esriGeometry.Point
Set pT2Min = New esriGeometry.Point
pT2Max.PutCoords pEnv.XMin, pEnv.YMax
pT1Max.PutCoords pEnv.XMax, pEnv.YMax
pT2Min.PutCoords pEnv.XMin, pEnv.YMin
pT1Min.PutCoords pEnv.XMax, pEnv.YMin
pMaxLine.PutCoords pT1Max, pT2Max
pMinLine.PutCoords pT1Min, pT2Min
Else
'pEnv.Expand 50, 50, True
'If the angle is not horizontal then the
'baselines are based on the egdes of the envelope +/- the input angle
Set pMinLine = New esriGeometry.Line
Set pMaxLine = New esriGeometry.Line
Set pT1Max = New esriGeometry.Point
Set pT2Min = New esriGeometry.Point
pT2Min.PutCoords pEnv.XMin, pEnv.YMax
Set pConspT1Min = New esriGeometry.Point
Set pLftBaseline = New esriGeometry.Line
Set pLftpb0 = New esriGeometry.Point
pLftpb0.PutCoords pEnv.XMin, pEnv.YMax
Set pLftpb1 = New esriGeometry.Point
pLftpb1.PutCoords pEnv.XMin, pEnv.YMin
pLftBaseline.PutCoords pLftpb0, pLftpb1
pConspT1Min.ConstructDeflection pLftBaseline, 2 * (pLftBaseline.Length / Cos((dpi / 2) - lAngle)), - ((dpi / 2) - lAngle)
Set pT1Min = pConspT1Min
pMinLine.PutCoords pT1Min, pT2Min
pT1Max.PutCoords pEnv.XMax, pEnv.YMin
Set pConspT2Max = New esriGeometry.Point
pConspT2Max.ConstructAngleDistance pT1Max, lAngle, pMinLine.Length
Set pT2Max = pConspT2Max
pMaxLine.PutCoords pT1Max, pT2Max
End If
Set pGeocoll = New GeometryBag
If lAngle > dpi / 2 Then
'In this case have to move he line
Set pmidpoint0 = New esriGeometry.Point
pmidpoint0.ConstructAlong pMinLine, esriNoExtension, 0.5, True
Set ptmid0 = pmidpoint0
dx0 = pEnv.XMin - ptmid0.X
dy0 = pEnv.YMin - ptmid0.Y
Set ptr0 = pMinLine
ptr0.Move dx0, dy0
pGeocoll.AddGeometry ptr0
Set pmidpoint1 = New esriGeometry.Point
pmidpoint1.ConstructAlong pMaxLine, esriNoExtension, 0.5, True
Set ptmid1 = pmidpoint1
dx1 = pEnv.XMax - ptmid1.X
dy1 = pEnv.YMax - ptmid1.Y
Set ptr1 = pMaxLine
ptr1.Move dx1, dy1
pGeocoll.AddGeometry ptr1
Else
pGeocoll.AddGeometry pMinLine
pGeocoll.AddGeometry pMaxLine
End If
Set createBaseLineByAngle = pGeocoll
Exit Function
errhand:
MsgBox Err.Description
Set createBaseLineByAngle = Nothing
End Function