Attribute VB_Name = "Clean"
Option Explicit

Private m_pGxDialog As IGxDialog
Private m_pGxObjectFilter As IGxObjectFilter

Public Sub Main()
  Dim pFeature As IFeature
  Dim pInFeatureClass As IFeatureClass
  Dim pFeatureCursor As IFeatureCursor
  Dim pGeometry As IGeometry
  Dim pInsertFeatureBuffer As IFeatureBuffer
  Dim pInsertFeatureCursor As IFeatureCursor
  Dim pOutFeatureClass As IFeatureClass
  Dim pProgressDlgFact As IProgressDialogFactory
  Dim pProgressDialog As IProgressDialog2
  Dim pStepProgressor As IStepProgressor
  Dim pTopoOperator As ITopologicalOperator2
  Dim pTrackCancel As ITrackCancel
  
  Dim bContinue As Boolean
  Dim lFeatureCount As Long
  Dim lTotalFeatureCount As Long
  Dim lEmptyFeatureCount As Long
  Dim sFinalMessage As String
  
  On Error GoTo ErrorHandler
  
  Set pInFeatureClass = GetShapefile
  If pInFeatureClass Is Nothing Then
    MsgBox "Error selecting Shapefile.  Exiting."
    Exit Sub
  End If
  
  'Exit if featureclass has no shapes
  lTotalFeatureCount = pInFeatureClass.FeatureCount(Nothing)
  If lTotalFeatureCount = 0 Then
    MsgBox "No features found in shapefile. Exiting"
    Exit Sub
  End If
  
  'Create a new Shapefile
  Set pOutFeatureClass = CreateNewShapefile(pInFeatureClass)
  If pOutFeatureClass Is Nothing Then
    MsgBox "Error creating new Shapefile, check folder permissions."
    Exit Sub
  End If
  
  'Show a progress dialog while we cycle through the features
  Set pTrackCancel = New CancelTracker
  Set pProgressDlgFact = New ProgressDialogFactory
  Set pProgressDialog = pProgressDlgFact.Create(pTrackCancel, 0)
  pProgressDialog.CancelEnabled = True
  pProgressDialog.Title = "Exporting and Cleaning Shapefile"
  pProgressDialog.Animation = esriProgressGlobe
  bContinue = True

  'Set the properties of the Step Progressor
  Set pStepProgressor = pProgressDialog
  pStepProgressor.MinRange = 0
  pStepProgressor.MaxRange = lTotalFeatureCount
  pStepProgressor.StepValue = 1
  
  'Create an insert cursor
  Set pInsertFeatureCursor = pOutFeatureClass.Insert(True)
  Set pInsertFeatureBuffer = pOutFeatureClass.CreateFeatureBuffer

  'Loop through all features in the feature class, correcting each one,
  'and write it out to the new shapefile
  Set pFeatureCursor = pInFeatureClass.Search(Nothing, False)
  Set pFeature = pFeatureCursor.NextFeature
  Do While Not pFeature Is Nothing
    'Update progress dialog
    lFeatureCount = lFeatureCount + 1
    pStepProgressor.Message = lFeatureCount & " of " & lTotalFeatureCount & " Features processed"
    'Stop processing features if 'Cancel' button is selected
    bContinue = pTrackCancel.Continue
    pStepProgressor.Step
    If Not bContinue Then Exit Do
    
    'If the feature has an invalid shape, create a new empty one
    If pFeature.Shape Is Nothing Then
      Set pFeature.Shape = CreateNewGeometry(pOutFeatureClass)
    End If
    'Simplify each feature and insert into new feature class
    Set pTopoOperator = pFeature.Shape
    pTopoOperator.IsKnownSimple = False
    pTopoOperator.Simplify
    InsertFeature pInsertFeatureCursor, pInsertFeatureBuffer, pFeature, pTopoOperator
    'Count number of empty features
    Set pGeometry = pTopoOperator
    If pGeometry.IsEmpty Then
      lEmptyFeatureCount = lEmptyFeatureCount + 1
    End If
    'Retrieve next feature
    Set pFeature = pFeatureCursor.NextFeature
  Loop
  
  pProgressDialog.HideDialog
  
  Set pInsertFeatureBuffer = Nothing
  Set pInsertFeatureCursor = Nothing
  
  'Recreate indexes on new Shapefile
  CreateIndexes pInFeatureClass, pOutFeatureClass
  
  'Create summary report message
  If bContinue Then
    sFinalMessage = "Operation completed successfully." & vbLf & vbLf
  Else
    sFinalMessage = "Job cancelled." & vbLf & vbLf
  End If
  sFinalMessage = sFinalMessage & lFeatureCount & " Features processed." & vbLf
  If Not lEmptyFeatureCount = 0 Then
    sFinalMessage = sFinalMessage & vbLf & lEmptyFeatureCount & " Features were found to have no shape."
  End If
  
  MsgBox sFinalMessage
  
  Set m_pGxObjectFilter = Nothing
  Set m_pGxDialog = Nothing
  
  Exit Sub 'Exit to avoid error handler
  
ErrorHandler:
  MsgBox "An unexpected error occurred." & vbLf & vbLf & _
          lFeatureCount & " Features processed." & vbLf
End Sub

Private Function GetShapefile() As IFeatureClass
  Dim pEnumGxObject As IEnumGxObject
  Dim pFeatureClass As IFeatureClass
  Dim pGxDataset As IGxDataset
  
  On Error GoTo ErrorHandler
  
  'Have the user select a shapefile
  Set m_pGxDialog = New GxDialog
  Set m_pGxObjectFilter = New GxFilterShapefiles
  
  Set m_pGxDialog.ObjectFilter = m_pGxObjectFilter
  m_pGxDialog.Title = "Select a Shapefile to Clean:"
  If m_pGxDialog.DoModalOpen(0, pEnumGxObject) Then
    pEnumGxObject.Reset
    Set pGxDataset = pEnumGxObject.Next
    Set pFeatureClass = pGxDataset.Dataset
  End If
  Set GetShapefile = pFeatureClass
  
  Exit Function
  
ErrorHandler:
  Set GetShapefile = Nothing
End Function

Private Function CreateNewShapefile(pInFeatureClass As IFeatureClass) As IFeatureClass
  Dim pClone As IClone
  Dim pFeatureWorkspace As IFeatureWorkspace
  Dim pFields As IFields
  Dim pGxFile As IGxFile
  Dim pNewFeatureClass As IFeatureClass
  Dim pWorkspaceFactory As IWorkspaceFactory
  
  On Error GoTo ErrorHandler
  
  m_pGxDialog.Title = "Enter New Output Shapefile:"
  If m_pGxDialog.DoModalSave(0) Then
    Set pGxFile = m_pGxDialog.FinalLocation
  Else
    Set CreateNewShapefile = Nothing
    Exit Function
  End If
  
  Set pWorkspaceFactory = New ShapefileWorkspaceFactory
  Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(pGxFile.Path, 0)
  Set pClone = pInFeatureClass.Fields
  Set pFields = pClone.Clone
  Set pNewFeatureClass = pFeatureWorkspace.CreateFeatureClass(m_pGxDialog.Name, pFields, Nothing, Nothing, esriFTSimple, pInFeatureClass.ShapeFieldName, "")
  Set CreateNewShapefile = pNewFeatureClass
  
  Exit Function
  
ErrorHandler:
  Set CreateNewShapefile = Nothing
  
End Function


Private Sub InsertFeature(pInsertFeatureCursor As IFeatureCursor, pInsertFeatureBuffer As IFeatureBuffer, pOrigFeature As IFeature, pGeometry As IGeometry)
  Dim pFields As IFields
  Dim pField As IField
  Dim pPoint As IPoint
  Dim FieldCount As Integer

  'Copy the attributes of the orig feature the new feature
  Set pFields = pOrigFeature.Fields
  For FieldCount = 0 To pFields.FieldCount - 1  'skip OID and geometry
    Set pField = pFields.Field(FieldCount)
    If Not pField.Type = esriFieldTypeGeometry And Not pField.Type = esriFieldTypeOID _
      And pField.Editable Then
        pInsertFeatureBuffer.Value(FieldCount) = pOrigFeature.Value(FieldCount)
    End If
  Next FieldCount
    
  Set pInsertFeatureBuffer.Shape = pGeometry
  pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
  
End Sub


Private Sub CreateIndexes(pInFeatureClass As IFeatureClass, pOutFeatureClass As IFeatureClass)
  Dim pClone As IClone
  Dim pOutIndexes As IIndexes
  Dim pIndex As IIndex
  Dim pNewIndex As IIndex
  Dim iIndexCount As Integer
  Dim pFields As IFields
  
  Set pClone = pInFeatureClass.Indexes
  Set pOutIndexes = pClone.Clone

  For iIndexCount = 0 To pOutIndexes.IndexCount - 1
    Set pNewIndex = pOutIndexes.Index(iIndexCount)
    Set pFields = pNewIndex.Fields
      pOutFeatureClass.AddIndex pNewIndex
  Next iIndexCount
  
End Sub

Private Function CreateNewGeometry(pFeatureClass As IFeatureClass) As IGeometry
  Select Case pFeatureClass.ShapeType
    Case esriGeometryPoint
      Set CreateNewGeometry = New Point
    Case esriGeometryMultipoint
      Set CreateNewGeometry = New Multipoint
    Case esriGeometryPolyline
      Set CreateNewGeometry = New Polyline
    Case esriGeometryPolygon
      Set CreateNewGeometry = New Polygon
  End Select
End Function