I current have two tools that draw polygons using the same method. I dissolve the zones, delete the undissolved zones, and then add the dissolved polygon to the map.
I keep getting "Coordinates or measure are out of bounds" on add the GeometryCollection to the IFeature.Shape property. This worked in VB6 back in 9.1, but I know things have changed. The error only happens after the first dissolve. I am assuming when it dissolves the polygons, it isn't carrying over its XY Domain/Envelope. I was wondering if anyone has some insight on what to do to fix this problem?
Here is the code that is bombs out on, if you need any other of the subroutine's code let me know (please know this is a huge system):
Public Sub UpdateLayer_AddPolygon(ByVal str_LayerName As String, ByVal pPolygon_New As IPolygon)
Dim pMxDoc_This As IMxDocument
Dim pFeatLayer_Out As IFeatureLayer
Dim pFeatClass_Out As IFeatureClass
Dim pFeat_New As IFeature
Dim pPolygon_Out As IPolygon
Dim pGeomColl_In As IGeometryCollection
Dim pGeomColl_Out As IGeometryCollection
Dim pSegmentColl_Ring As ISegmentCollection
Dim pMap As IMap
Dim pClone_1 As esriSystem.IClone
Dim i_SegNum As Long
On Error GoTo ErrorHandler
pMxDoc_This = My.ArcMap.Application.Document
pMap = My.ArcMap.Document.FocusMap
pFeatLayer_Out = FindLayer_ByLayerName(str_LayerName)
pFeatClass_Out = pFeatLayer_Out.FeatureClass
'¶¶ Verify that the specified layer is of type polygon:
If Not pFeatClass_Out.ShapeType = esriGeometryType.esriGeometryPolygon Then
MsgBox("The output layer, ''" + str_LayerName + "'' must be of type polygon.", vbExclamation, "CW Inspection Operations")
Exit Sub
End If
'Create new polygon in collection:
pGeomColl_Out = New Polygon
'Clone the incoming polygon, so we can use the references to the new segments:
pClone_1 = pPolygon_New
pGeomColl_In = pClone_1.Clone
'Transfer the segments from the polygon paths to new rings and add the rings to the new polygon:
For i_SegNum = 0 To pGeomColl_In.GeometryCount - 1
pSegmentColl_Ring = New Ring
pSegmentColl_Ring.AddSegmentCollection(pGeomColl_In.Geometry(i_SegNum))
pGeomColl_Out.AddGeometry(pSegmentColl_Ring)
Next i_SegNum
'Store the polygon in the specified layer:
pFeat_New = pFeatClass_Out.CreateFeature
pFeat_New.Shape = pGeomColl_Out 'Crashes Here
pFeat_New.Store()
'Refresh the display.
pMxDoc_This.ActiveView.PartialRefresh(esriViewDrawPhase.esriViewGeography, Nothing, Nothing)
Exit Sub
ErrorHandler:
Select Case Err.Number
Case -2147220936 'coordinates or measures out of bounds (80040238)
MsgBox("The Coordinates or Measures are Out of Bounds.", _
vbInformation, "Out of Bounds")
Exit Sub
Case Else
MsgBox(Err.Number & ": " & "Could not draw polygon in this area. The Coordinates or Measures are Out of Bounds.")
End Select
Exit Sub
End Sub 'UpdateLayer_AddPolygon
And here is the dissolve code:
Public Sub DissolvePerim(ByVal str_FeatClassName_Perim As String)
Dim pFeatLayer_Output As IFeatureLayer
Dim pFeatClass_Output As IFeatureClass
Dim pBasicGeoProc_1 As IBasicGeoprocessor
Dim pFeatClass_Input As IFeatureClass
Dim pWorkspaceName_New As IWorkspaceName
Dim pFeatClassName_1 As IFeatureClassName
Dim pTable_Input As ITable
Dim pTable_Output As ITable
'dataset objects:
Dim pDatasetName_1 As IDatasetName
'layer objects:
Dim pFeatLayer_Input As IFeatureLayer
Dim pFeatLayer_Perim As IFeatureLayer
Dim pFeatLayer_Perim_Dissolved As IFeatureLayer
Dim pFeatClassName_Perim As IFeatureClassName
Dim pFeatClassName_Perim_Dissolved As IFeatureClassName
Dim str_PathedFileName_DB As String
Dim str_SummaryFields As String
Dim pField_1 As IField
Dim pFieldEdit_1 As IFieldEdit
Dim pDataset_Temp As IDataset
'Locate the database file:
str_PathedFileName_DB = GetNPath_DB() + "CWInspect_Perims.mdb"
If g_b_DebugMode Then
MsgBox("Database file: ''" + str_PathedFileName_DB + "''", vbInformation, "CW Inspection Operations")
End If
'Find the perimeter layer:
pFeatLayer_Input = FindLayer_ByFeatClassName(str_FeatClassName_Perim)
'¶¶
If pFeatLayer_Input Is Nothing Then
MsgBox("The ''" + str_FeatClassName_Perim + "'' layer was not found")
Exit Sub
End If
'Find the dissolved perimeter layer:
pFeatLayer_Output = FindLayer_ByFeatClassName(str_FeatClassName_Perim + "_dissolved")
'¶¶
If pFeatLayer_Output Is Nothing Then
MsgBox("The ''" + str_FeatClassName_Perim + "_dissolved'' layer was not found", vbApplicationModal Or vbCritical Or vbOKOnly, "CW Inspection Operations")
Exit Sub
End If
'Get the input table:
pTable_Input = pFeatLayer_Input
' ( Use the ITable interface from the FeatureLayer, not from the FeatureClass )
'¶¶
If pTable_Input Is Nothing Then
MsgBox("Table QI failed.", vbApplicationModal Or vbCritical Or vbOKOnly, "CW Inspection Operations")
Exit Sub
End If
'Make sure there is a field named "SUB" in the input layer:
If pTable_Input.FindField("SUB") = -1 Then
'Create the "SUB" field:
pField_1 = New Field
pFieldEdit_1 = pField_1
pFieldEdit_1.Name_2 = "SUB"
pFieldEdit_1.AliasName_2 = "SUB"
pFieldEdit_1.Type_2 = esriFieldType.esriFieldTypeString
pFieldEdit_1.Length_2 = 5
pTable_Input.AddField(pField_1)
End If
'Get the feature class properties needed for the output:
pFeatClass_Input = pFeatLayer_Input.FeatureClass
pFeatClassName_1 = New FeatureClassName
With pFeatClassName_1
.FeatureType = esriFeatureType.esriFTSimple
.ShapeFieldName = "Shape"
.ShapeType = pFeatClass_Input.ShapeType
End With
Call DeleteFeatureClass(str_PathedFileName_DB, "dissolve_work")
'Set the output location and output feature class name:
pWorkspaceName_New = New WorkspaceName
pWorkspaceName_New.WorkspaceFactoryProgID = "esriDataSourcesGDB.AccessWorkspaceFactory.1"
pWorkspaceName_New.PathName = str_PathedFileName_DB
pDatasetName_1 = pFeatClassName_1
pDatasetName_1.Name = "dissolve_work"
pDatasetName_1.WorkspaceName = pWorkspaceName_New
'Perform the dissolve:
pBasicGeoProc_1 = New BasicGeoprocessor
str_SummaryFields = "Dissolve.Shape, Sum.SUB"
pTable_Output = pBasicGeoProc_1.Dissolve(pTable_Input, False, "SUB", str_SummaryFields, pDatasetName_1)
' ( Since we are performing a spatial dissolve, we must use the operation code
' "Dissolve" on the Shape field. )
' ( The "dissolveField" parameter MUST point to a text field in order to work properly. )
pFeatClass_Output = pTable_Output
'¶¶
If pFeatClass_Output Is Nothing Then
MsgBox("FeatureClass QI failed.")
Exit Sub
End If
pFeatLayer_Perim = FindLayer_ByFeatClassName(str_FeatClassName_Perim)
pFeatLayer_Perim_Dissolved = FindLayer_ByFeatClassName(str_FeatClassName_Perim + "_dissolved")
pFeatLayer_Output.FeatureClass = pFeatClass_Output
'Remove all shapes from the perimeter (un-dissolved) layer:
Call EmptyLayer(FindLayer_ByFeatClassName(str_FeatClassName_Perim), False)
'Get the perimeter workspace and feature class name object:
pDataset_Temp = pFeatLayer_Perim.FeatureClass
pFeatClassName_Perim = pDataset_Temp.FullName
'Get the dissolved perimeter workspace and feature class name object:
pDataset_Temp = pFeatLayer_Perim_Dissolved.FeatureClass
pFeatClassName_Perim_Dissolved = pDataset_Temp.FullName
'Copy the dissolved perimeter shapes to the perimeter layer.
Call CopyLayerShapes(pFeatClassName_Perim_Dissolved, pFeatClassName_Perim, Nothing)
End Sub 'DissolvePerim
