Attribute VB_Name = "FixSI"
Public Sub FixSpatialIndices()

   ' **** FixSpatialIndices() - Run in ArcCatalog
   
   ' **** This script checks the spatial index for each feature class
   ' **** in a selected personal geodatabase and rebuilds it if there
   ' **** is a discrepancy in record counts.
   
   On Error Resume Next
   
   ' Get selected object and check that it is a personal geodatabase
   
   Dim pApp As IGxApplication, pGO As IGxObject
   Set pApp = Application
   Set pGO = pApp.SelectedObject
   Test = pGO.category
   If Not Test = "Personal Geodatabase" Then
      MsgBox "Please select a personal geodatabase.", vbExclamation, "Fix Spatial Indices"
      Exit Sub
   End If
   
   ' Open feature workspace
   
   Dim WSName As String
   Dim pWSF As IWorkspaceFactory
   Dim pWS As IFeatureWorkspace
   
   WSName = pGO.FullName
   Set pWSF = New AccessWorkspaceFactory
   Set pWS = pWSF.OpenFromFile(WSName, pApp.View.hWnd)
   
   ' Open temporary log file
   
   Dim fs, a
   Set fs = CreateObject("Scripting.FileSystemObject")
   Dim tempname As String, temppath As String
   temppath = Environ("TEMP")
   tempname = fs.BuildPath(temppath, fs.GetTempName)
   Set a = fs.CreateTextFile(tempname, True)
   a.WriteLine "The following feature classes were updated:"
   
   ' Get and loop through feature classes
   
   Dim pWksp As IWorkspace
   Dim pDatasets As IEnumDataset
   Dim pDataset As IDataset
   Dim TName As String, SIName As String
   Dim pSITab As ITable
   Dim n As Boolean
   
   Set pWksp = pWS
   Set pDatasets = pWksp.Datasets(esriDTFeatureClass)
   Set pDataset = pDatasets.Next
   Do While Not pDataset Is Nothing
   
      TName = pDataset.Name
      Application.StatusBar.Message(0) = "Checking " & TName & "..."
      DoEvents
      SIName = TName & "_SHAPE_INDEX"
      Set pSITab = Nothing
      Set pSITab = pWS.OpenTable(SIName)
      If Not pSITab Is Nothing Then
         n = RebuildSI(pWS, SIName, TName)
         If n Then
            a.WriteLine TName
         End If
      End If
      Set pDataset = pDatasets.Next
      
   Loop
   
   Application.StatusBar.Message(0) = "Done."
   DoEvents
   a.Close
   Shell "notepad " & tempname, vbNormalFocus
   
End Sub

Public Function RebuildSI(pWS As IFeatureWorkspace, SIName As String, TName As String) As Boolean
   
   ' **** The section of code marked [OPTIONAL] may be commented out
   ' **** if you wish to force an update of all spatial indices.
   
   On Error Resume Next

   Dim pTab As ITable, pSITab As ITable
   Set pSITab = pWS.OpenTable(SIName)
   Set pTab = pWS.OpenTable(TName)
   Dim pQF As IQueryFilter
   Set pQF = Nothing
   
   '**** [OPTIONAL] BEGIN
   
   ' Check record count
   
   Application.StatusBar.Message(0) = "Querying " & SIName & "... "
   DoEvents
   
   Dim pQFShape As IQueryFilter
   Set pQFShape = New QueryFilter
   pQFShape.WhereClause = "[shape] is null"
   Dim iSI As Long, iRec As Long, iNull As Long
   iSI = pSITab.RowCount(pQF)
   iRec = pTab.RowCount(pQF)
   iNull = pTab.RowCount(pQFShape)
   If iSI = iRec - iNull Then
      RebuildSI = False
      Exit Function
   End If
   
   '**** [OPTIONAL] END
   
   ' Empty spatial index table
   
   Dim pWSE As IWorkspaceEdit
   Set pWSE = pWS
   pWSE.DisableUndoRedo
   pWSE.StartEditing False
   pWSE.StartEditOperation
   
   Application.StatusBar.Message(0) = "Erasing " & SIName & "... "
   DoEvents
   
   pSITab.DeleteSearchedRows pQF
   
   pWSE.StopEditOperation
   pWSE.StopEditing True
   
   ' Now rebuild spatial index
   
   Dim pCursor As IFeatureCursor
   Set pCursor = pTab.Update(pQF, False)
   
   Dim pFeat As IFeature
   Dim iShape As IGeometry
   Set pFeat = pCursor.NextFeature
   Dim i As Long
   i = 0
   Do While Not pFeat Is Nothing
      i = i + 1
      If i Mod 100 = 0 Then
         Application.StatusBar.Message(0) = "Updating " & TName & "... " & i
         DoEvents
      End If
      If i Mod 10000 = 0 Then
         pWSE.StopEditOperation
         pWSE.StopEditing True
         pWSE.StartEditing False
         pWSE.StartEditOperation
      End If
      Set iShape = pFeat.Shape
      Set pFeat.Shape = iShape
      pCursor.UpdateFeature pFeat
      Set pFeat = pCursor.NextFeature
   Loop
      
   pWSE.StopEditOperation
   pWSE.StopEditing True
   
   RebuildSI = True

End Function