How to cycle through all polygons in one layer then generalize them?
Key Words: Generalize, Polygons ,Layer,ArcGIS,AO
Private Function ProcessGeneralize(iLyrIndex As Integer)
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pFeatureCursor As IFeatureCursor
Dim pFLyrFile, pFeatureLayer As IFeatureLayer
Dim pFeatureSelection As IFeatureSelection
Dim pFeatureClass As IFeatureClass
'Dim pInvalidArea As IInvalidArea
Dim pSelectionSet As ISelectionSet
Dim pFeature As IFeature
Dim pPolygon As IPolygon
Dim pLayer As ILayer
Dim pPointCollection As IPointCollection
Dim pFields As IFields
'Dim QueFilter As IQueryFilter
Dim pEnumFeat As IEnumFeature
Dim pID As New UID
'Dim pFeature As IFeature
Dim i, iBFPointCounts, iAFPointCounts As Integer
Dim iScaleNumber, iRowscount As Integer
Dim lngShapeFieldIndex As Long
Dim strShapeFileName As String
Dim bLayerExists As Boolean
Dim MyXLApp As Excel.Application
'////////////////////////////////////////////////////////////////////////////////////
iBFPointCounts = iAFPointCounts = 0
iScaleNumber = CInt(txtGenScale.Text)
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
If pMap.LayerCount = 0 Then
MsgBox "No layers in the active data frame", vbCritical, "Operation terminated"
GoTo CLEANUP
End If
'////////////////////////////////////////////////////////////////////////////////////
Set pFeatureLayer = pMap.Layer(iLyrIndex)
Set pFeatureClass = pFeatureLayer.FeatureClass
Set pFields = pFeatureClass.Fields
lngShapeFieldIndex = pFields.FindField("Shape")
strShapeFileName = pFeatureLayer.Name
'////////////////////////////////////////////////////////////////////////////////////
'Prepare to cycle through all polygon layer and gereralized all polygon and record its number
'////////////////////////////////////////////////////////////////////////////////////
Set pFeatureSelection = pFeatureLayer
pFeatureSelection.SelectFeatures Nothing, esriSelectionResultNew, False ' select all features
Set pSelectionSet = pFeatureSelection.SelectionSet
pSelectionSet.Search Nothing, False, pFeatureCursor ' creates the feature cursor
Set pFeature = pFeatureCursor.NextFeature
ProgressBar1.Max = 100 'Set the max of progress bar
ProgressBar1.Visible = True
ProgressBar1.Value = 0
'////////////////////////////////////////////////////////////////////////////////////
Set MyXLApp = New Excel.Application
MyXLApp.Workbooks.Open FileName:=GB_OUTPUT_FILE_PATH & "Output.xls"
iRowscount = MyXLApp.ActiveSheet.UsedRange.Rows.count
Debug.Print iRowscount
'////////////////////////////////////////////////////////////////////////////////////
While Not pFeature Is Nothing
Set pPolygon = pFeature.Shape
Set pPointCollection = pPolygon
iBFPointCounts = iBFPointCounts + pPointCollection.PointCount
'////////////////////////////////////////////////////////////////////////////////////
pPolygon.Generalize iScaleNumber 'Generalize the polygon
'////////////////////////////////////////////////////////////////////////////////////
Set pPointCollection = pPolygon
'save
Set pFeature.Shape = pPolygon
pFeature.Store
iAFPointCounts = iAFPointCounts + pPointCollection.PointCount
'////////////////////////////////////////////////////////////////////////////////////
'move to next polygon
Set pFeature = pFeatureCursor.NextFeature
ProgressBar1.Value = ProgressBar1.Value + Int(100 / CInt(pFeatureSelection.SelectionSet.count))
Wend
'////////////////////////////////////////////////////////////////////////////////////
'Prepare to cycle through all polygon and gereralized all polygon
'////////////////////////////////////////////////////////////////////////////////////
MyXLApp.Cells(iRowscount + 1, 1).Value = pFeatureLayer.Name
MyXLApp.Cells(iRowscount + 1, 2).Value = pFeatureLayer.ScaleSymbols
lblBeforePoints.Caption = iBFPointCounts
lblAfterPoints.Caption = iAFPointCounts
MyXLApp.Cells(iRowscount + 1, 3).Value = iScaleNumber
MyXLApp.Cells(iRowscount + 1, 4).Value = "Total Points before Gen : " & CStr(iBFPointCounts)
MyXLApp.Cells(iRowscount + 1, 5).Value = "Total Point after Gen : " & CStr(iAFPointCounts)
MyXLApp.Cells(iRowscount + 1, 6).Value = Date & "/" & Time
'////////////////////////////////////////////////////////////////////////////////////
ProgressBar1.Visible = False
'////////////////////////////////////////////////////////////////////////////////////
If MsgBox("Save Generalized result to Layer ?", vbYesNo + vbQuestion, "Save Modification") = vbYes Then
Set pItem = ThisDocument.CommandBars.Find(Editor_SaveEdits)
pItem.Execute
'pEditor.StopEditing True
End If
'////////////////////////////////////////////////////////////////////////////////////
Set pItem = ThisDocument.CommandBars.Find(Editor_StopEditing)
pItem.Execute 'Quit Editing Mode
'////////////////////////////////////////////////////////////////////////////////////
'pMxDoc.FocusMap
'////////////////////////////////////////////////////////////////////////////////////
CommandButton1.Enabled = False
MyXLApp.ActiveWorkbook.Save
MyXLApp.ActiveWorkbook.Close
MyXLApp.Quit
Debug.Print "quit excel successfully"
Set MyXLApp = Nothing
CLEANUP:
Set pMxDoc = Nothing
Set pMap = Nothing
Set pPolygon = Nothing
'Set pArea = Nothing
Set pFeatureClass = Nothing
Set pFeatureLayer = Nothing
Set pFeature = Nothing
Set pFeatureSelection = Nothing
Set pSelectionSet = Nothing
Set pFeatureCursor = Nothing
End Function
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pFeatureCursor As IFeatureCursor
Dim pFLyrFile, pFeatureLayer As IFeatureLayer
Dim pFeatureSelection As IFeatureSelection
Dim pFeatureClass As IFeatureClass
'Dim pInvalidArea As IInvalidArea
Dim pSelectionSet As ISelectionSet
Dim pFeature As IFeature
Dim pPolygon As IPolygon
Dim pLayer As ILayer
Dim pPointCollection As IPointCollection
Dim pFields As IFields
'Dim QueFilter As IQueryFilter
Dim pEnumFeat As IEnumFeature
Dim pID As New UID
'Dim pFeature As IFeature
Dim i, iBFPointCounts, iAFPointCounts As Integer
Dim iScaleNumber, iRowscount As Integer
Dim lngShapeFieldIndex As Long
Dim strShapeFileName As String
Dim bLayerExists As Boolean
Dim MyXLApp As Excel.Application
'////////////////////////////////////////////////////////////////////////////////////
iBFPointCounts = iAFPointCounts = 0
iScaleNumber = CInt(txtGenScale.Text)
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
If pMap.LayerCount = 0 Then
MsgBox "No layers in the active data frame", vbCritical, "Operation terminated"
GoTo CLEANUP
End If
'////////////////////////////////////////////////////////////////////////////////////
Set pFeatureLayer = pMap.Layer(iLyrIndex)
Set pFeatureClass = pFeatureLayer.FeatureClass
Set pFields = pFeatureClass.Fields
lngShapeFieldIndex = pFields.FindField("Shape")
strShapeFileName = pFeatureLayer.Name
'////////////////////////////////////////////////////////////////////////////////////
'Prepare to cycle through all polygon layer and gereralized all polygon and record its number
'////////////////////////////////////////////////////////////////////////////////////
Set pFeatureSelection = pFeatureLayer
pFeatureSelection.SelectFeatures Nothing, esriSelectionResultNew, False ' select all features
Set pSelectionSet = pFeatureSelection.SelectionSet
pSelectionSet.Search Nothing, False, pFeatureCursor ' creates the feature cursor
Set pFeature = pFeatureCursor.NextFeature
ProgressBar1.Max = 100 'Set the max of progress bar
ProgressBar1.Visible = True
ProgressBar1.Value = 0
'////////////////////////////////////////////////////////////////////////////////////
Set MyXLApp = New Excel.Application
MyXLApp.Workbooks.Open FileName:=GB_OUTPUT_FILE_PATH & "Output.xls"
iRowscount = MyXLApp.ActiveSheet.UsedRange.Rows.count
Debug.Print iRowscount
'////////////////////////////////////////////////////////////////////////////////////
While Not pFeature Is Nothing
Set pPolygon = pFeature.Shape
Set pPointCollection = pPolygon
iBFPointCounts = iBFPointCounts + pPointCollection.PointCount
'////////////////////////////////////////////////////////////////////////////////////
pPolygon.Generalize iScaleNumber 'Generalize the polygon
'////////////////////////////////////////////////////////////////////////////////////
Set pPointCollection = pPolygon
'save
Set pFeature.Shape = pPolygon
pFeature.Store
iAFPointCounts = iAFPointCounts + pPointCollection.PointCount
'////////////////////////////////////////////////////////////////////////////////////
'move to next polygon
Set pFeature = pFeatureCursor.NextFeature
ProgressBar1.Value = ProgressBar1.Value + Int(100 / CInt(pFeatureSelection.SelectionSet.count))
Wend
'////////////////////////////////////////////////////////////////////////////////////
'Prepare to cycle through all polygon and gereralized all polygon
'////////////////////////////////////////////////////////////////////////////////////
MyXLApp.Cells(iRowscount + 1, 1).Value = pFeatureLayer.Name
MyXLApp.Cells(iRowscount + 1, 2).Value = pFeatureLayer.ScaleSymbols
lblBeforePoints.Caption = iBFPointCounts
lblAfterPoints.Caption = iAFPointCounts
MyXLApp.Cells(iRowscount + 1, 3).Value = iScaleNumber
MyXLApp.Cells(iRowscount + 1, 4).Value = "Total Points before Gen : " & CStr(iBFPointCounts)
MyXLApp.Cells(iRowscount + 1, 5).Value = "Total Point after Gen : " & CStr(iAFPointCounts)
MyXLApp.Cells(iRowscount + 1, 6).Value = Date & "/" & Time
'////////////////////////////////////////////////////////////////////////////////////
ProgressBar1.Visible = False
'////////////////////////////////////////////////////////////////////////////////////
If MsgBox("Save Generalized result to Layer ?", vbYesNo + vbQuestion, "Save Modification") = vbYes Then
Set pItem = ThisDocument.CommandBars.Find(Editor_SaveEdits)
pItem.Execute
'pEditor.StopEditing True
End If
'////////////////////////////////////////////////////////////////////////////////////
Set pItem = ThisDocument.CommandBars.Find(Editor_StopEditing)
pItem.Execute 'Quit Editing Mode
'////////////////////////////////////////////////////////////////////////////////////
'pMxDoc.FocusMap
'////////////////////////////////////////////////////////////////////////////////////
CommandButton1.Enabled = False
MyXLApp.ActiveWorkbook.Save
MyXLApp.ActiveWorkbook.Close
MyXLApp.Quit
Debug.Print "quit excel successfully"
Set MyXLApp = Nothing
CLEANUP:
Set pMxDoc = Nothing
Set pMap = Nothing
Set pPolygon = Nothing
'Set pArea = Nothing
Set pFeatureClass = Nothing
Set pFeatureLayer = Nothing
Set pFeature = Nothing
Set pFeatureSelection = Nothing
Set pSelectionSet = Nothing
Set pFeatureCursor = Nothing
End Function
