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.
How to use
- Copy the code into a new module in VBA.
- Modify the source code to point to the correct data location and correct field names.
- 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
'Settings
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 pPolycurve As IPolycurve
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!"
Else
'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
pWorkingCurve.ReverseOrientation
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 pPolycurve = pStreetFeature.ShapeCopy
pPolycurve.SplitAtDistance 0.5, True, False, True, 0, 0
Set pFeatureCurve = pPolycurve
Set pPoint = pFeatureCurve.FromPoint
If XYEqual(pPoint, pLastCurveEnd) Then
pSegmentCollection.AddSegmentCollection pFeatureCurve
Else
Set pPoint = pFeatureCurve.ToPoint
If XYEqual(pPoint, pLastCurveEnd) Then
pFeatureCurve.ReverseOrientation
pSegmentCollection.AddSegmentCollection pFeatureCurve
Else
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)!"
Else
'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
Loop
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)
Else
'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
Else
XYEqual = False
End If
End Function