Create Turn Feature Class From Multi-Edge Turn Table


This sample demonstrates how to create a new turn feature class from a turn table that contains multiple edges per turn. It assumes the following:
  • Both the streets shapefile and turn table are in the same folder.
  • Each turn is represented by exactly one row of the turn table.
  • The streets that make up the turn are referenced by a unique ID on the streets shapefile.
  • The turn lists the unique IDs of each street in the turn in its Street1, Street2, ..., Street7 fields.
  • For turns with fewer than seven streets, the unused Street# fields have a value of zero.
  • All other fields on the turn table will be copied to the turn feature class.
Commercial street data is sold in many different formats. This sample can be modified to match the data layout of your street dataset. It also can be modified to work on geodatabase data.
ArcView: VBA

Extension: Network Analyst Extension

Platforms: Windows

Minimum ArcGIS Release: 9.1

How to use:
  1. Copy the code into a new module in VBA.
  2. Modify the source code to point to the correct data location and correct field names.
  3. Run the VBA code.

Option Explicit

Sub CreateTurnFeatureClassFromMultiEdgeTurnTable()
  Dim sToolboxesFolder As String
  Dim sFolderPath As String
  Dim sTurnFCName As String
  Dim sStreetsFCName As String
  Dim sTurnTableName As String
  Dim sFieldsToCopy() As String
  Dim iNumFieldsToCopy As Integer
  Dim sStreetIDField As String
  Dim sTurnTableIDFields() As String
  Dim iNumTurnTableIDFields As Integer
  Dim sTurnTableOrientationField As String
  Dim sOrientationYesValue As String
  Dim sOrientationNoValue As String
  Dim dTrimRatio As Double
  sToolboxesFolder = "C:\Program Files\ArcGIS\ArcToolbox\Toolboxes\"
  sFolderPath = "C:\MyData\"
  sTurnFCName = "MyNewTurnFC"
  sStreetsFCName = "MyStreets"
  sTurnTableName = "MyTurnTable"
  iNumFieldsToCopy = 4
  ReDim sFieldsToCopy(1 To iNumFieldsToCopy)
  sFieldsToCopy(1) = "TurnID"
  sFieldsToCopy(2) = "TurnType"
  sFieldsToCopy(3) = "TravelTime"
  sFieldsToCopy(4) = "HrsOfOper"
  sStreetIDField = "StreetID"
  iNumTurnTableIDFields = 7
  ReDim sTurnTableIDFields(1 To iNumTurnTableIDFields)
  sTurnTableIDFields(1) = "Street1"
  sTurnTableIDFields(2) = "Street2"
  sTurnTableIDFields(3) = "Street3"
  sTurnTableIDFields(4) = "Street4"
  sTurnTableIDFields(5) = "Street5"
  sTurnTableIDFields(6) = "Street6"
  sTurnTableIDFields(7) = "Street7"
  sTurnTableOrientationField = "TurnEnd"
  sOrientationYesValue = "T"
  sOrientationNoValue = "F"
  dTrimRatio = 0.25
  Dim GP As Object, SR As Variant, i As Integer
  Dim pWorkspaceFactory As IWorkspaceFactory
  Dim pFeatureWorkspace As IFeatureWorkspace
  Dim pTurnFC As IFeatureClass
  Dim pStreetsFC As IFeatureClass
  Dim pTurnTable As ITable
  Dim pStreetIDField As IField
  Dim pFieldEdit As IFieldEdit
  Dim pField As IField
  Dim iTurnTableIDFields() As Integer
  Dim iTurnTableFieldsToCopy() As Integer
  Dim iTurnTableOrientationField As Integer
  Dim iTurnFCEdgeFCIDFields() As Integer
  Dim iTurnFCEdgeFIDFields() As Integer
  Dim iTurnFCEdgePosFields() As Integer
  Dim iTurnFCAltIDFields() As Integer
  Dim iTurnFCEdge1EndField As Integer
  Dim iTurnFCFieldsToCopy() As Integer
  Dim pDict As Object
  Dim pInsertFeatureCursor As IFeatureCursor
  Dim pFeatureBuffer As IFeatureBuffer
  Dim pCursor As ICursor
  Dim pRow As IRow
  Dim vStreetID As Variant
  Dim pStreetFeature As IFeature
  Dim iNumEdges As Integer
  Dim bErrorFound As Boolean
  Dim pSegmentCollection As ISegmentCollection
  Dim pWorkingCurve As ICurve
  Dim pFeatureCurve As ICurve
  Dim dLastCurveLength As Double
  Dim pLastCurveEnd As IPoint
  Dim pPoint As IPoint
  ReDim iTurnTableIDFields(1 To iNumTurnTableIDFields)
  ReDim iTurnTableFieldsToCopy(1 To iNumFieldsToCopy)
  ReDim iTurnFCEdgeFCIDFields(1 To iNumTurnTableIDFields)
  ReDim iTurnFCEdgeFIDFields(1 To iNumTurnTableIDFields)
  ReDim iTurnFCEdgePosFields(1 To iNumTurnTableIDFields)
  ReDim iTurnFCAltIDFields(1 To iNumTurnTableIDFields)
  ReDim iTurnFCFieldsToCopy(1 To iNumFieldsToCopy)
  'Create the geoprocessing dispatch object and use it to create a new turn feature class
  Set GP = CreateObject("esriGeoprocessing.GPDispatch")
  GP.Toolbox = sToolboxesFolder & "Data Management Tools.tbx"
  SR = GP.CreateSpatialReference("", sFolderPath & sStreetsFCName & ".shp")
  GP.Toolbox = sToolboxesFolder & "Network Analyst Tools.tbx"
  GP.CreateTurnFeatureClass sFolderPath, sTurnFCName, CStr(iNumTurnTableIDFields), "", "", SR
  'Open the shapefile workspace and get references to the shapefiles
  Set pWorkspaceFactory = New ShapefileWorkspaceFactory
  Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sFolderPath, 0)
  Set pTurnFC = pFeatureWorkspace.OpenFeatureClass(sTurnFCName)
  Set pStreetsFC = pFeatureWorkspace.OpenFeatureClass(sStreetsFCName)
  Set pTurnTable = pFeatureWorkspace.OpenTable(sTurnTableName)
  'Add the alternate ID fields to the turn feature class based the street feature class's ID field
  Set pStreetIDField = pStreetsFC.Fields.Field(pStreetsFC.FindField(sStreetIDField))
  For i = 1 To iNumTurnTableIDFields
    Set pFieldEdit = New Field
    With pFieldEdit
      .Name = "AltID" & i
      .Precision = pStreetIDField.Precision
      .Scale = pStreetIDField.Scale
      .Type = pStreetIDField.Type
    End With
    pTurnFC.AddField pFieldEdit
  Next i
  'Create new fields on the turn feature class for the FieldsToCopy fields
  For i = 1 To iNumFieldsToCopy
    With pTurnTable
      Set pField = .Fields.Field(.FindField(sFieldsToCopy(i)))
    End With
    pTurnFC.AddField pField
  Next i
  'Look up the field indices on the turn table and turn feature class
  For i = 1 To iNumTurnTableIDFields
    iTurnTableIDFields(i) = pTurnTable.FindField(sTurnTableIDFields(i))
    iTurnFCEdgeFCIDFields(i) = pTurnFC.FindField("Edge" & i & "FCID")
    iTurnFCEdgeFIDFields(i) = pTurnFC.FindField("Edge" & i & "FID")
    iTurnFCEdgePosFields(i) = pTurnFC.FindField("Edge" & i & "Pos")
    iTurnFCAltIDFields(i) = pTurnFC.FindField("AltID" & i)
  Next i
  iTurnFCEdge1EndField = pTurnFC.FindField("Edge1End")
  For i = 1 To iNumFieldsToCopy
    iTurnTableFieldsToCopy(i) = pTurnTable.FindField(sFieldsToCopy(i))
    iTurnFCFieldsToCopy(i) = pTurnFC.FindField(sFieldsToCopy(i))
  Next i
  iTurnTableOrientationField = pTurnTable.FindField(sTurnTableOrientationField)
  'Instantiate a dictionary object to hold previously fetched street features
  Set pDict = CreateObject("Scripting.Dictionary")
  'Create an insert cursor on the turn feature class and create a feature buffer
  Set pInsertFeatureCursor = pTurnFC.Insert(True)
  Set pFeatureBuffer = pTurnFC.CreateFeatureBuffer
  'Loop through all rows of the turn table and create a turn feature from each row
  Set pCursor = pTurnTable.Search(Nothing, True)
  Set pRow = pCursor.NextRow
  Do Until pRow Is Nothing
    'Process the first street in this turn
    vStreetID = pRow.Value(iTurnTableIDFields(1))
    Set pStreetFeature = LookUpStreetFeature(vStreetID, pStreetsFC, sStreetIDField, pDict)
    If pStreetFeature Is Nothing Then
      Debug.Print "ERROR: Turn Table Row " & pRow.OID & ": First street of the turn (" & vStreetID & ") could not be found!"
      'Reset the processing flags from the previous iteration
      bErrorFound = False
      iNumEdges = 1
      'Set the Edge1FCID, Edge1FID, Edge1Pos, and AltID1 field values
      pFeatureBuffer.Value(iTurnFCEdgeFCIDFields(1)) = pStreetsFC.FeatureClassID
      pFeatureBuffer.Value(iTurnFCEdgeFIDFields(1)) = pStreetFeature.OID
      pFeatureBuffer.Value(iTurnFCEdgePosFields(1)) = 0.5
      pFeatureBuffer.Value(iTurnFCAltIDFields(1)) = vStreetID
      'Get the geometry of the first street in the turn, flip it (if necessary) and trim it'And set the Edge1End field value
      Set pFeatureCurve = pStreetFeature.ShapeCopy
      Select Case pRow.Value(iTurnTableOrientationField)
        Case sOrientationYesValue
          pFeatureCurve.GetSubcurve (1# - dTrimRatio), 1#, True, pWorkingCurve
          pFeatureBuffer.Value(iTurnFCEdge1EndField) = "Y"
        Case sOrientationNoValue
          pFeatureCurve.GetSubcurve 0#, dTrimRatio, True, pWorkingCurve
          pFeatureBuffer.Value(iTurnFCEdge1EndField) = "N"
        Case Else
          Debug.Print "ERROR: Turn Table Row " & pRow.OID & ": Invalid " & sTurnTableOrientationField & " field value!"
          Set pWorkingCurve = Nothing
          bErrorFound = True
      End Select
      If Not pWorkingCurve Is Nothing Then
        'Create a new polyline and add the trimmed first street geometry to it
        Set pSegmentCollection = New Polyline
        pSegmentCollection.AddSegmentCollection pWorkingCurve
        Set pLastCurveEnd = pWorkingCurve.ToPoint     'Remember the last point of the curve'Process the remaining streets in this turn
        For i = 2 To iNumTurnTableIDFields
          vStreetID = pRow.Value(iTurnTableIDFields(i))
          If vStreetID = 0 Then     'This means that the last record was the last street in this turn
            Exit For
          End If
          Set pStreetFeature = LookUpStreetFeature(vStreetID, pStreetsFC, sStreetIDField, pDict)
          If pStreetFeature Is Nothing Then
            Debug.Print "ERROR: Turn Table Row " & pRow.OID & ": Street #" & i & " (" & vStreetID & ") could not be found!"
            bErrorFound = True
            Exit For
          End If
          'Set the Edge[i]FCID, Edge[i]FID, Edge[i]Pos, and AltID[i] field values
          pFeatureBuffer.Value(iTurnFCEdgeFCIDFields(i)) = pStreetsFC.FeatureClassID
          pFeatureBuffer.Value(iTurnFCEdgeFIDFields(i)) = pStreetFeature.OID
          pFeatureBuffer.Value(iTurnFCEdgePosFields(i)) = 0.5
          pFeatureBuffer.Value(iTurnFCAltIDFields(i)) = vStreetID
          'Get the geometry of this street in the turn, flip it (if necessary) and add it to the segment collection
          Set pFeatureCurve = pStreetFeature.ShapeCopy
          Set pPoint = pFeatureCurve.FromPoint
          If XYEqual(pPoint, pLastCurveEnd) Then
            pSegmentCollection.AddSegmentCollection pFeatureCurve
            Set pPoint = pFeatureCurve.ToPoint
            If XYEqual(pPoint, pLastCurveEnd) Then
              pSegmentCollection.AddSegmentCollection pFeatureCurve
              Debug.Print "ERROR: Turn Table Row " & pRow.OID & ": Street #" & i & " (" & vStreetID & ") is discontinuous with previous curve!"
              bErrorFound = True
              Exit For
            End If
          End If
          dLastCurveLength = pFeatureCurve.Length       'Remember the length of the last curve added
          Set pLastCurveEnd = pFeatureCurve.ToPoint     'And remember the last point of the curve'Report the number of edges processed so far in this turn
          iNumEdges = i
        Next i
        If Not bErrorFound Then
          If iNumEdges < 2 Then
            Debug.Print "ERROR: Turn Table Row " & pRow.OID & ": Turn only contains " & iNumEdges & " edge(s)!"
            'Trim the segment such that the last curve is the length of the trim ratio
            Set pWorkingCurve = pSegmentCollection
            pWorkingCurve.GetSubcurve 0#, pWorkingCurve.Length - ((1# - dTrimRatio) * dLastCurveLength), False, pFeatureCurve
            Set pFeatureBuffer.Shape = pFeatureCurve
            'Zero out the unused Edge[i]FCID, Edge[i]FID, Edge[i]Pos, and AltID[i] fields
            For i = (iNumEdges + 1) To iNumTurnTableIDFields
              pFeatureBuffer.Value(iTurnFCEdgeFCIDFields(i)) = 0
              pFeatureBuffer.Value(iTurnFCEdgeFIDFields(i)) = 0
              pFeatureBuffer.Value(iTurnFCEdgePosFields(i)) = 0
              pFeatureBuffer.Value(iTurnFCAltIDFields(i)) = 0
            Next i
            'For each turn table field to copy, copy its field value to the turn feature class
            For i = 1 To iNumFieldsToCopy
              pFeatureBuffer.Value(iTurnFCFieldsToCopy(i)) = pRow.Value(iTurnTableFieldsToCopy(i))
            Next i
            'Create the turn feature and go on to the next row in the turn table
            pInsertFeatureCursor.InsertFeature pFeatureBuffer
          End If
        End If
      End If
    End If
    Set pRow = pCursor.NextRow
End Sub

Function LookUpStreetFeature(ByVal vStreetID As Variant, ByRef pStreetsFC As IFeatureClass, ByVal sStreetIDField As String, ByRef pDict As Object) As IFeature
  Dim pFeature As IFeature
  Dim pQueryFilter As IQueryFilter
  Dim pFeatureCursor As IFeatureCursor
  If pDict.Exists(vStreetID) Then
    'If the feature is already in the dictionary, get it from there
    Set pFeature = pDict.Item(vStreetID)
    'Otherwise, set up the query filter, perform a search on the streets feature class,'and return the first feature found
    Set pQueryFilter = New QueryFilter
    pQueryFilter.WhereClause = sStreetIDField & " = " & vStreetID
    Set pFeatureCursor = pStreetsFC.Search(pQueryFilter, False)
    Set pFeature = pFeatureCursor.NextFeature
    'If a feature was found, add it to the dictionary for future retrieval
    If Not pFeature Is Nothing Then
      pDict.Add vStreetID, pFeature
    End If
  End If
  Set LookUpStreetFeature = pFeature
End Function

Function XYEqual(pA As IPoint, pB As IPoint) As Boolean
  If pA.X = pB.X And pA.Y = pB.Y Then
    XYEqual = True
    XYEqual = False
  End If
End Function