Dissolve sections in a .SEC table

Created:8/29/2000
Description:

This code demonstrates how to reduce the number of sections in a .SEC by combining records that meet certain requirements. These requirements are outlined in the code below.

How to use:
  1. Paste the code into VB/VBA.
  2. Change the code to point to your data.
  3. Run the code.
Public Sub DissolveSections()

  '+++ After many edits to a coverage route system, you may have more
  '+++ sections in the .SEC than you expected. Use this routine to 'dissolve'
  '+++ sections.
  
  '+++ Make a backup of your data before running this code as there
  '+++ is no way to undo the changes!!!
  
  '+++ Note: All attribute values after SUBCLASS# in the .SEC are not re-initialized.
  
  
  '+++ Get the .SEC table
  
  Dim pFact As IWorkspaceFactory
  Set pFact = New ArcInfoWorkspaceFactory
  Dim pWorkspace As IWorkspace
    
  Set pWorkspace = pFact.OpenFromFile("\\rockytop\data\dyndata", 0)
  Dim pFeatWS As IFeatureWorkspace
  Set pFeatWS = pWorkspace
  Dim pSECTable As ITable
  Set pSECTable = pFeatWS.OpenTable("roads.sechwy")
  
  
  '+++ Set up some tolerances. You can change any of these to achieve slightly
  '+++ different results
  
  Dim deltaPosition As Double '+++ used to nullify the efects of floating point numbers
  deltaPosition = 0.0001
  Dim deltaMeasure As Double '+++ used to nullify the efects of floating point numbers
  deltaMeasure = 0.0001
  Dim deltaRatio As Double '+++ for comparing length-measure ratio
  deltaRatio = 0.015
  
  
  '+++ Open the first cursor: Update cursor
  Dim pCursor1 As ICursor
  Set pCursor1 = pSECTable.Update(Nothing, True)
  
  '+++ Open the second cursor: Query cursor
  Dim pCursor2 As ICursor
  Set pCursor2 = pSECTable.Search(Nothing, True)
  
  '+++ Get the first row for both cursors
  Dim pRow1 As IRow
  Dim pRow2 As IRow
  
  Set pRow1 = pCursor1.NextRow
  Set pRow2 = pCursor2.NextRow
  
  '+++ Define the field indices
  Dim ridIdx As Long
  Dim arcIdx As Long
  Dim fmIdx As Long
  Dim tmIdx As Long
  Dim fpIdx As Long
  Dim tpIdx As Long
  ridIdx = 1
  arcIdx = 2
  fmIdx = 3
  tmIdx = 4
  fpIdx = 5
  tpIdx = 6
  
  '+++ Cache the reference values
  Dim rid1 As Variant
  Dim arc1 As Variant
  Dim fm1  As Double
  Dim tm1  As Double
  Dim fp1  As Double
  Dim tp1  As Double
  Dim r1   As Double
  
  rid1 = pRow2.Value(ridIdx)
  arc1 = pRow2.Value(arcIdx)
  fm1 = pRow2.Value(fmIdx)
  tm1 = pRow2.Value(tmIdx)
  fp1 = pRow2.Value(fpIdx)
  tp1 = pRow2.Value(tpIdx)
  If Not tp1 - fp1 = 0 Then
    r1 = Abs(tm1 - fm1) / Abs(tp1 - fp1)
  Else
    r1 = 0
  End If
  
  '+++ Start to loop and dissolve
  Dim rid2 As Variant
  Dim arc2 As Variant
  Dim fm2  As Double
  Dim tm2  As Double
  Dim fp2  As Double
  Dim tp2  As Double
  Dim r2   As Double
  
  Dim dissolve As Boolean
  
  Set pRow2 = pCursor2.NextRow
  Do While Not (pRow2 Is Nothing)
    rid2 = pRow2.Value(ridIdx)
    arc2 = pRow2.Value(arcIdx)
    fm2 = pRow2.Value(fmIdx)
    tm2 = pRow2.Value(tmIdx)
    fp2 = pRow2.Value(fpIdx)
    tp2 = pRow2.Value(tpIdx)
    If Not tp2 - fp2 = 0 Then
      r2 = Abs(tm2 - fm2) / Abs(tp2 - fp2)
    Else
      r2 = r1
    End If
  
    '+++ We can dissolve if:
    '+++    1. the RouteLink# of the current and previous section are the same
    '+++    2. the Arclink# of the current and previous section are the same
    '+++    3. the F-POS of the current section is the same (or within a tolerance)
    '+++       of the T-Pos of the previous section,
    '+++    4. the F-MEAS of the current section is the same (or within a tolerance) of
    '+++       the T-MEAS of the previous section
    '+++    5. the length-measure ratio of the current section is the same (or within
    '+++       a tolerance) of the previous section
    
    dissolve = rid1 = rid2 And arc1 = arc2
    dissolve = dissolve And Abs(fp2 - tp1) < deltaPosition
    dissolve = dissolve And Abs(fm2 - tm1) < deltaMeasure
    dissolve = dissolve And Abs(r2 - r1) < deltaRatio
    
    If dissolve Then
      '+++ Dissolve the measures into row #1 (sections are being 'bubbled up')
      pRow1.Value(tpIdx) = tp2
      pRow1.Value(tmIdx) = tm2
      tp1 = tp2
      tm1 = tm2
      r1 = Abs(tm1 - fm1) / Abs(tp1 - fp1)
    Else
      If Not (Abs(r2 - r1) < deltaRatio) Then
        Debug.Print "ROW1: " & rid1 & " : " & arc1 & " : " & fp1 & " : " & tp1 & " : " & fm1 & " : " & tm1 & " : " & r1
        Debug.Print "ROW2: " & rid2 & " : " & arc2 & " : " & fp2 & " : " & tp2 & " : " & fm2 & " : " & tm2 & " : " & r2
        Debug.Print "CAN'T DISSOLVE: " & Abs(r2 - r1)
      End If
      '+++ Move pCursor1 to the next row, update it with the value from the cursor #2
      '+++ and cache the values from cursor #2 as new reference values
      Set pRow1 = pCursor1.NextRow
      pRow1.Value(ridIdx) = rid2
      pRow1.Value(arcIdx) = arc2
      pRow1.Value(fmIdx) = fm2
      pRow1.Value(tmIdx) = tm2
      pRow1.Value(fpIdx) = fp2
      pRow1.Value(tpIdx) = tp2
      rid1 = rid2
      arc1 = arc2
      fp1 = fp2
      tp1 = tp2
      fm1 = fm2
      tm1 = tm2
      r1 = r2
    End If
    pCursor1.UpdateRow pRow1
    Set pRow2 = pCursor2.NextRow
  Loop
  
  
  '+++ At this point cursor #2 reached the end of the section table.
  '+++ We can delete all the records remaining from the position of cursor #1
  Set pRow1 = pCursor1.NextRow
  Dim cDeleted As Long
  cDeleted = 0
  Do While Not (pRow1 Is Nothing)
    cDeleted = cDeleted + 1
    pCursor1.DeleteRow
    Set pRow1 = pCursor1.NextRow
  Loop
  Debug.Print "ROWS DELETED: " & cDeleted

End Sub