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
- Paste the code into VBA.
- Change the code to point to your data.
- Run the code.
Public Sub DissolveSections(sArcInfoWS As String, sSECTable As String)
'+++ Variables
'+++ sArcInfoWS - ArcInfo Workspace (i.e "\\rockytop\data\dyndata")
'+++ sSECTable - the section table (i.e "roads.sechwy")
'+++ 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(sArcInfoWS, 0)
Dim pFeatWS As IFeatureWorkspace
Set pFeatWS = pWorkspace
Dim pSECTable As ITable
Set pSECTable = pFeatWS.OpenTable(sSECTable)
'+++ 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