POST
|
Here, try this.
Sub CentroidQuadrants()
' Buffers the centroid of a polygon and divides the resulting circle into 4 even-sized quadrants
' creating a separate polygon feature for each quadrant of the circle.
Dim pMxd As IMxDocument
Set pMxd = ThisDocument
Dim pUID As UID
Set pUID = New UID
pUID.Value = "esriEditor.Editor"
Dim pEditor As IEditor
Set pEditor = Application.FindExtensionByCLSID(pUID)
If (pEditor Is Nothing) Then
MsgBox "Failed to get a reference to the ArcMap Editor!"
Exit Sub
End If
Dim pEnumFeature As IEnumFeature
Set pEnumFeature = pMxd.FocusMap.FeatureSelection
pEnumFeature.Reset
Dim pSearchFeature As IFeature
Set pSearchFeature = pEnumFeature.Next
If (pSearchFeature Is Nothing) Then
MsgBox "Please select a feature!"
Exit Sub
End If
Dim pLayer As ILayer
Dim pFeatureLayer As IFeatureLayer
Dim i As Integer
For i = 0 To pMxd.FocusMap.LayerCount - 1
Set pLayer = pMxd.FocusMap.Layer(i)
If pLayer.Name = "Land Parcel SG Approved (Land Parcel)" Then
Set pFeatureLayer = pLayer
Exit For
End If
Next
If (pFeatureLayer Is Nothing) Then
MsgBox "Land Parcel layer not found!"
Exit Sub
End If
Dim pDataset As IDataset
Set pDataset = pFeatureLayer.FeatureClass
pEditor.StartEditing pDataset.Workspace
' If this macro fails even once, the Editor will become bedwangled.
' When this happens, uncomment the StopOperation() below to keep moving.
' pEditor.StopOperation "Create circle quadrants"
pEditor.StartOperation
Dim pArea As IArea
Set pArea = pSearchFeature.Shape
Dim pCentroid As IPoint
Set pCentroid = pArea.Centroid
Dim pTopoOp As ITopologicalOperator
Set pTopoOp = pCentroid
Dim pBufferedPoint As IGeometry
Set pBufferedPoint = pTopoOp.Buffer(100)
Dim pFeature As IFeature
' This stores the original circle from the buffered centroid
' Set pFeature = pFeatureLayer.FeatureClass.CreateFeature
' Set pFeature.Shape = pBufferedPoint
' pFeature.Store
Dim pCircleEnvelope As IEnvelope
Set pCircleEnvelope = pBufferedPoint.Envelope
Dim pEnv As IEnvelope
Dim pPointCollection As IPointCollection
' LOWER LEFT
Set pEnv = New Envelope
Set pEnv.SpatialReference = pCentroid.SpatialReference
pEnv.PutCoords pCircleEnvelope.LowerLeft.X, pCircleEnvelope.LowerLeft.Y, pCircleEnvelope.LowerRight.X - (pCircleEnvelope.Width / 2), pCircleEnvelope.UpperLeft.Y - (pCircleEnvelope.Height / 2)
Dim pQuadrantPoly As IPolygon
Set pQuadrantPoly = New Polygon
Set pQuadrantPoly.SpatialReference = pCentroid.SpatialReference
Set pPointCollection = pQuadrantPoly
Dim pLLPoint As IPoint
Dim pULPoint As IPoint
Dim pURPoint As IPoint
Dim pLRPoint As IPoint
Set pLLPoint = New Point
Set pULPoint = New Point
Set pURPoint = New Point
Set pLRPoint = New Point
pLLPoint.PutCoords pEnv.LowerLeft.X, pEnv.LowerLeft.Y
pULPoint.PutCoords pEnv.UpperLeft.X, pEnv.UpperLeft.Y
pURPoint.PutCoords pEnv.UpperRight.X, pEnv.UpperRight.Y
pLRPoint.PutCoords pEnv.LowerRight.X, pEnv.LowerRight.Y
pPointCollection.AddPoint pLLPoint
pPointCollection.AddPoint pULPoint
pPointCollection.AddPoint pURPoint
pPointCollection.AddPoint pLRPoint
pQuadrantPoly.Close
pQuadrantPoly.SimplifyPreserveFromTo
If pQuadrantPoly.IsEmpty Then
MsgBox "Failed to create lower left quadrant!"
End If
Set pFeature = pFeatureLayer.FeatureClass.CreateFeature
Set pTopoOp = pQuadrantPoly
Set pFeature.Shape = pTopoOp.Intersect(pBufferedPoint, esriGeometry2Dimension)
pFeature.Store
' LOWER RIGHT
Set pEnv = New Envelope
Set pEnv.SpatialReference = pCentroid.SpatialReference
pEnv.PutCoords pCircleEnvelope.LowerRight.X - (pCircleEnvelope.Width / 2), pCircleEnvelope.LowerLeft.Y, pCircleEnvelope.LowerRight.X, pCircleEnvelope.UpperLeft.Y - (pCircleEnvelope.Height / 2)
Set pQuadrantPoly = New Polygon
Set pQuadrantPoly.SpatialReference = pCentroid.SpatialReference
Set pPointCollection = pQuadrantPoly
Set pLLPoint = New Point
Set pULPoint = New Point
Set pURPoint = New Point
Set pLRPoint = New Point
pLLPoint.PutCoords pEnv.LowerLeft.X, pEnv.LowerLeft.Y
pULPoint.PutCoords pEnv.UpperLeft.X, pEnv.UpperLeft.Y
pURPoint.PutCoords pEnv.UpperRight.X, pEnv.UpperRight.Y
pLRPoint.PutCoords pEnv.LowerRight.X, pEnv.LowerRight.Y
pPointCollection.AddPoint pLLPoint
pPointCollection.AddPoint pULPoint
pPointCollection.AddPoint pURPoint
pPointCollection.AddPoint pLRPoint
pQuadrantPoly.Close
pQuadrantPoly.SimplifyPreserveFromTo
If pQuadrantPoly.IsEmpty Then
MsgBox "Failed to create lower right polygon!"
End If
Set pFeature = pFeatureLayer.FeatureClass.CreateFeature
Set pTopoOp = pQuadrantPoly
Set pFeature.Shape = pTopoOp.Intersect(pBufferedPoint, esriGeometry2Dimension)
pFeature.Store
' UPPER LEFT
Set pEnv = New Envelope
Set pEnv.SpatialReference = pCentroid.SpatialReference
pEnv.PutCoords pCircleEnvelope.LowerLeft.X, pCircleEnvelope.UpperLeft.Y - (pCircleEnvelope.Height / 2), pCircleEnvelope.LowerRight.X - (pCircleEnvelope.Width / 2), pCircleEnvelope.UpperLeft.Y
Set pQuadrantPoly = New Polygon
Set pQuadrantPoly.SpatialReference = pCentroid.SpatialReference
Set pPointCollection = pQuadrantPoly
Set pLLPoint = New Point
Set pULPoint = New Point
Set pURPoint = New Point
Set pLRPoint = New Point
pLLPoint.PutCoords pEnv.LowerLeft.X, pEnv.LowerLeft.Y
pULPoint.PutCoords pEnv.UpperLeft.X, pEnv.UpperLeft.Y
pURPoint.PutCoords pEnv.UpperRight.X, pEnv.UpperRight.Y
pLRPoint.PutCoords pEnv.LowerRight.X, pEnv.LowerRight.Y
pPointCollection.AddPoint pLLPoint
pPointCollection.AddPoint pULPoint
pPointCollection.AddPoint pURPoint
pPointCollection.AddPoint pLRPoint
pQuadrantPoly.Close
pQuadrantPoly.SimplifyPreserveFromTo
If pQuadrantPoly.IsEmpty Then
MsgBox "Failed to create upper left polygon!"
End If
Set pFeature = pFeatureLayer.FeatureClass.CreateFeature
Set pTopoOp = pQuadrantPoly
Set pFeature.Shape = pTopoOp.Intersect(pBufferedPoint, esriGeometry2Dimension)
pFeature.Store
' UPPER RIGHT
Set pEnv = New Envelope
Set pEnv.SpatialReference = pCentroid.SpatialReference
pEnv.PutCoords pCircleEnvelope.LowerRight.X - (pCircleEnvelope.Width / 2), pCircleEnvelope.UpperLeft.Y - (pCircleEnvelope.Height / 2), pCircleEnvelope.LowerRight.X, pCircleEnvelope.UpperLeft.Y
Set pQuadrantPoly = New Polygon
Set pQuadrantPoly.SpatialReference = pCentroid.SpatialReference
Set pPointCollection = pQuadrantPoly
Set pLLPoint = New Point
Set pULPoint = New Point
Set pURPoint = New Point
Set pLRPoint = New Point
pLLPoint.PutCoords pEnv.LowerLeft.X, pEnv.LowerLeft.Y
pULPoint.PutCoords pEnv.UpperLeft.X, pEnv.UpperLeft.Y
pURPoint.PutCoords pEnv.UpperRight.X, pEnv.UpperRight.Y
pLRPoint.PutCoords pEnv.LowerRight.X, pEnv.LowerRight.Y
pPointCollection.AddPoint pLLPoint
pPointCollection.AddPoint pULPoint
pPointCollection.AddPoint pURPoint
pPointCollection.AddPoint pLRPoint
pQuadrantPoly.Close
pQuadrantPoly.SimplifyPreserveFromTo
If pQuadrantPoly.IsEmpty Then
MsgBox "Failed to create upper right polygon!"
End If
Set pFeature = pFeatureLayer.FeatureClass.CreateFeature
Set pTopoOp = pQuadrantPoly
Set pFeature.Shape = pTopoOp.Intersect(pBufferedPoint, esriGeometry2Dimension)
pFeature.Store
' ...... all quadrants created ......
pEditor.StopOperation "Create circle quadrants"
pEditor.StopEditing True
Dim pActiveView As IActiveView
Set pActiveView = pMxd.FocusMap
pActiveView.Refresh
End Sub
... View more
02-20-2011
10:07 PM
|
0
|
0
|
124
|
POST
|
Does the problem occur with any map document, or are you always testing using the same Mxd?
... View more
02-17-2011
11:29 PM
|
0
|
0
|
226
|
POST
|
The freezing sounds very much like a threading deadlock of sorts. Just out of curiosity, what happens if you remove the Application.ProcessMessages from your Status() procedure? Alternatively comment out all code in Status() and see if anything changes. I'm not sure if you have the option to compile to x64 in Delphi, but in .NET we've seen some pretty erratic behavior when forgetting to specify an x86 target platform. You may find this of interest: Programming with ArcObjects 9.3 in Delphi 7, 2005, 2006, 2007, and 2009 http://arcscripts.esri.com/details.asp?dbid=14204
... View more
02-16-2011
10:35 PM
|
0
|
0
|
226
|
POST
|
Sub SpatialFilter()
Dim pMxd As IMxDocument
Set pMxd = ThisDocument
Dim pEnumFeature As IEnumFeature
Set pEnumFeature = pMxd.FocusMap.FeatureSelection
pEnumFeature.Reset
Dim pSearchFeature As IFeature
Set pSearchFeature = pEnumFeature.Next
If (pSearchFeature Is Nothing) Then
MsgBox "Please select a feature to search."
Exit Sub
End If
pMxd.FocusMap.ClearSelection
Dim pLayer As ILayer
Dim pSearchLayer As IFeatureLayer
Dim pFeatureLayer As IFeatureLayer
Dim i As Integer
For i = 0 To pMxd.FocusMap.LayerCount - 1
Set pLayer = pMxd.FocusMap.Layer(i)
If pLayer.Name = "Roads" Then
Set pSearchLayer = pLayer
Exit For
End If
Next
If (pSearchLayer Is Nothing) Then
MsgBox "Roads layer not found!"
Exit Sub
End If
For i = 0 To pMxd.FocusMap.LayerCount - 1
Set pLayer = pMxd.FocusMap.Layer(i)
If pLayer.Name = "Road Assets" Then
Set pFeatureLayer = pLayer
Exit For
End If
Next
If (pSearchLayer Is Nothing) Then
MsgBox "Road Assets layer not found!"
Exit Sub
End If
Dim pSpatialFilter As ISpatialFilter
Set pSpatialFilter = New SpatialFilter
Dim pTopoOp As ITopologicalOperator
Set pTopoOp = pSearchFeature.Shape
' You might need to buffer the search geometry in certain cases.
' Use a buffer value of 0 to search using the original geometry.
Dim pSearchGeometry As IGeometry
Set pSearchGeometry = pTopoOp.Buffer(10)
Set pSpatialFilter.Geometry = pSearchGeometry
pSpatialFilter.GeometryField = pSearchLayer.FeatureClass.ShapeFieldName
pSpatialFilter.SpatialRel = esriSpatialRelIntersects
Dim pFeatureCursor As IFeatureCursor
Set pFeatureCursor = pFeatureLayer.Search(pSpatialFilter, False)
Dim pFeature As IFeature
Dim FeatureCount As Integer
Set pFeature = pFeatureCursor.NextFeature
Do While Not pFeature Is Nothing
FeatureCount = FeatureCount + 1
pMxd.FocusMap.SelectFeature pFeatureLayer, pFeature
Set pFeature = pFeatureCursor.NextFeature
Loop
If (FeatureCount = 1) Then
MsgBox FeatureCount & " feature found."
Else
MsgBox FeatureCount & " features found."
End If
Dim pActiveView As IActiveView
Set pActiveView = pMxd.FocusMap
pActiveView.Refresh
End Sub
... View more
02-15-2011
11:39 PM
|
0
|
0
|
365
|
Online Status |
Offline
|
Date Last Visited |
11-11-2020
02:23 AM
|