Service area solver
frmServiceAreaSolver.vb
' Copyright 2012 ESRI
' 
' All rights reserved under the copyright laws of the United States
' and applicable international laws, treaties, and conventions.
' 
' You may freely redistribute and use this sample code, with or
' without modification, provided you include the original copyright
' notice and use restrictions.
' 
' See the use restrictions.
' 

Imports Microsoft.VisualBasic
Imports System
Imports System.Windows.Forms
Imports ESRI.ArcGIS.Geodatabase
Imports ESRI.ArcGIS.NetworkAnalyst
Imports ESRI.ArcGIS.Carto
Imports ESRI.ArcGIS.esriSystem
Imports ESRI.ArcGIS.Geometry

Namespace ServiceAreaSolver
  Partial Public Class frmServiceAreaSolver
    Inherits Form
    Private m_naContext As INAContext

#Region "Main Form Constructor and Setup"

    Public Sub New()
      InitializeComponent()

      txtCutOff.Text = "5"
      lbOutput.Items.Clear()
      cbCostAttribute.Items.Clear()
      ckbUseRestriction.Checked = False
      axMapControl.ClearLayers()

      txtWorkspacePath.Text = Application.StartupPath & "\..\..\..\..\..\Data\SanFrancisco\SanFrancisco.gdb"
      txtNetworkDataset.Text = "Streets_ND"
      txtFeatureDataset.Text = "Transportation"
      txtInputFacilities.Text = "Hospitals"
      gbServiceAreaSolver.Enabled = False
    End Sub

#End Region

#Region "Button Clicks"

    Private Sub btnSolve_Click(ByVal sender As Object, ByVal e As EventArgs) Handles btnSolve.Click
      Me.Cursor = Cursors.WaitCursor
      lbOutput.Items.Clear()

            Dim gpMessages As IGPMessages = New GPMessagesClass()
            Try
                ConfigureSolverSettings()

                If (Not m_naContext.Solver.Solve(m_naContext, gpMessages, Nothing)) Then
                    lbOutput.Items.Add("Partial Result")
                End If

                DisplayOutput()

            Catch ex As Exception
                lbOutput.Items.Add("Solve Failed: " & ex.Message)
            End Try

            lbOutput.Items.Add(GetGPMessagesAsString(GPMessages))
            UpdateMapDisplayAfterSolve()

            Me.Cursor = Cursors.Default
        End Sub

        '*********************************************************************************
        ' Gather the error/warning/informative messages from GPMessages
        '*********************************************************************************
        Public Function GetGPMessagesAsString(ByVal gpMessages As IGPMessages) As String

            Dim messages As System.Text.StringBuilder = New System.Text.StringBuilder()
            If Not gpMessages Is Nothing Then
                Dim i As Integer
                For i = 0 To gpMessages.Count - 1
                    Dim gpMessage As IGPMessage = gpMessages.GetMessage(i)
                    Dim message As String = gpMessage.Description
                    Select Case gpMessage.Type
                        Case esriGPMessageType.esriGPMessageTypeError
                            messages.AppendLine("Error " + gpMessage.ErrorCode.ToString + ": " + message)
                        Case esriGPMessageType.esriGPMessageTypeWarning
                            messages.AppendLine("Warning: " + message)
                        Case Else
                            messages.AppendLine("Information: " + message)
                    End Select
                Next
            End If

            Return messages.ToString()
        End Function

        Private Sub btnLoadMap_Click(ByVal sender As Object, ByVal e As EventArgs) Handles btnLoadMap.Click
            Me.Cursor = Cursors.WaitCursor

            gbServiceAreaSolver.Enabled = False
            lbOutput.Items.Clear()

            ' Open geodatabase and network dataset
            Dim featureWorkspace As IFeatureWorkspace = Nothing
            Dim networkDataset As INetworkDataset = Nothing

            Try
                Dim workspace As IWorkspace = OpenWorkspace(Application.StartupPath & "\..\..\..\..\..\Data\SanFrancisco\SanFrancisco.gdb")
                networkDataset = OpenNetworkDataset(workspace, "Transportation", "Streets_ND")
                featureWorkspace = TryCast(workspace, IFeatureWorkspace)
            Catch ex As Exception
                Windows.Forms.MessageBox.Show("Unable to open dataset. Error Message: " + ex.Message)
                Me.Cursor = Cursors.Default
                Return
            End Try

            CreateContextAndSolver(networkDataset)
            If m_naContext Is Nothing Then
                Me.Cursor = Cursors.Default
                Return
            End If

            LoadCostAttributes(networkDataset)
            If (Not LoadLocations(featureWorkspace)) Then
                Me.Cursor = Cursors.Default
                Return
            End If

            AddNetworkDatasetLayerToMap(networkDataset)
            AddNetworkAnalysisLayerToMap()

            ' work around a transparency issue
            Dim geoDataset As IGeoDataset = TryCast(networkDataset, IGeoDataset)
            axMapControl.Extent = axMapControl.FullExtent
            axMapControl.Extent = geoDataset.Extent

            If m_naContext IsNot Nothing Then
                gbServiceAreaSolver.Enabled = True
            End If

            Me.Cursor = Cursors.Default
        End Sub

#End Region

#Region "Set up Context and Solver"

        '*********************************************************************************
        ' Geodatabase functions
        '*********************************************************************************
        Public Function OpenWorkspace(ByVal strGDBName As String) As IWorkspace
            ' As Workspace Factories are Singleton objects, they must be instantiated with the Activator
            Dim workspaceFactory As IWorkspaceFactory = TryCast(Activator.CreateInstance(Type.GetTypeFromProgID("esriDataSourcesGDB.FileGDBWorkspaceFactory")), IWorkspaceFactory)
            Return workspaceFactory.OpenFromFile(strGDBName, 0)
        End Function

        '*********************************************************************************
        ' Open the network dataset
        '*********************************************************************************
        Public Function OpenNetworkDataset(ByVal workspace As IWorkspace, ByVal featureDatasetName As String, ByVal strNDSName As String) As INetworkDataset
            ' Obtain the dataset container from the workspace
            Dim featureWorkspace As IFeatureWorkspace = TryCast(workspace, IFeatureWorkspace)
            Dim featureDataset As IFeatureDataset = featureWorkspace.OpenFeatureDataset(featureDatasetName)
            Dim featureDatasetExtensionContainer As IFeatureDatasetExtensionContainer = TryCast(featureDataset, IFeatureDatasetExtensionContainer)
            Dim featureDatasetExtension As IFeatureDatasetExtension = featureDatasetExtensionContainer.FindExtension(ESRI.ArcGIS.Geodatabase.esriDatasetType.esriDTNetworkDataset)
            Dim datasetContainer3 As IDatasetContainer3 = TryCast(featureDatasetExtension, IDatasetContainer3)

            ' Use the container to open the network dataset
            Dim dataset As Object = datasetContainer3.DatasetByName(ESRI.ArcGIS.Geodatabase.esriDatasetType.esriDTNetworkDataset, strNDSName)
            Return TryCast(dataset, INetworkDataset)
        End Function

        Private Sub CreateContextAndSolver(ByVal networkDataset As INetworkDataset)
            If networkDataset Is Nothing Then
                Return
            End If

            Dim datasetComponent As IDatasetComponent = TryCast(networkDataset, IDatasetComponent)
            Dim deNetworkDataset As IDENetworkDataset = TryCast(datasetComponent.DataElement, IDENetworkDataset)

            Dim naSolver As INASolver = New NAServiceAreaSolverClass()
            m_naContext = naSolver.CreateContext(deNetworkDataset, "ServiceArea")
            Dim naContextEdit As INAContextEdit = TryCast(m_naContext, INAContextEdit)
            naContextEdit.Bind(networkDataset, New GPMessagesClass())
        End Sub

#End Region

#Region "Load Form Controls"

        Private Sub LoadCostAttributes(ByVal networkDataset As INetworkDataset)
            cbCostAttribute.Items.Clear()

            Dim attrCount As Integer = networkDataset.AttributeCount
            For attrIndex As Integer = 0 To attrCount - 1
                Dim networkAttribute As INetworkAttribute = networkDataset.Attribute(attrIndex)
                If networkAttribute.UsageType = esriNetworkAttributeUsageType.esriNAUTCost Then
                    cbCostAttribute.Items.Add(networkAttribute.Name)
                End If
            Next attrIndex

            If cbCostAttribute.Items.Count > 0 Then
                cbCostAttribute.SelectedIndex = 0
            End If
        End Sub

        Private Function LoadLocations(ByVal featureWorkspace As IFeatureWorkspace) As Boolean
            Dim inputFeatureClass As IFeatureClass = Nothing
            Try
                inputFeatureClass = featureWorkspace.OpenFeatureClass(txtInputFacilities.Text)
            Catch e1 As Exception
                MessageBox.Show("Specified input feature class does not exist")
                Return False
            End Try

            Dim classes As INamedSet = m_naContext.NAClasses
            Dim naClass As INAClass = TryCast(classes.ItemByName("Facilities"), INAClass)

            ' delete existing locations, except barriers
            naClass.DeleteAllRows()

            ' Create a NAClassLoader and set the snap tolerance (meters unit)
            Dim naClassLoader As INAClassLoader = New NAClassLoaderClass()
            naClassLoader.Locator = m_naContext.Locator
            naClassLoader.Locator.SnapTolerance = 100
            naClassLoader.NAClass = naClass

            ' Create field map to automatically map fields from input class to NAClass
            Dim naClassFieldMap As INAClassFieldMap = New NAClassFieldMapClass()
            naClassFieldMap.CreateMapping(naClass.ClassDefinition, inputFeatureClass.Fields)
            naClassLoader.FieldMap = naClassFieldMap

            ' Avoid loading network locations onto non-traversable portions of elements
            Dim locator As INALocator3 = TryCast(m_naContext.Locator, INALocator3)
            locator.ExcludeRestrictedElements = True
            locator.CacheRestrictedElements(m_naContext)

            ' load network locations
            Dim rowsIn As Integer = 0
            Dim rowsLocated As Integer = 0
            naClassLoader.Load(TryCast(inputFeatureClass.Search(Nothing, True), ICursor), Nothing, rowsIn, rowsLocated)

            If rowsLocated <= 0 Then
                MessageBox.Show("Facilities were not loaded from input feature class")
                Return False
            End If

            ' Message all of the network analysis agents that the analysis context has changed
            Dim naContextEdit As INAContextEdit = TryCast(m_naContext, INAContextEdit)
            naContextEdit.ContextChanged()

            Return True
        End Function

        Private Sub AddNetworkAnalysisLayerToMap()
            Dim layer As ILayer = TryCast(m_naContext.Solver.CreateLayer(m_naContext), ILayer)
            layer.Name = m_naContext.Solver.DisplayName
            axMapControl.AddLayer(layer)
        End Sub

        Private Sub AddNetworkDatasetLayerToMap(ByVal networkDataset As INetworkDataset)
            Dim networkLayer As INetworkLayer = New NetworkLayerClass()
            networkLayer.NetworkDataset = networkDataset
            Dim layer As ILayer = TryCast(networkLayer, ILayer)
            layer.Name = "Network Dataset"
            axMapControl.AddLayer(layer)
        End Sub

#End Region

#Region "Solver Settings"

        Private Sub ConfigureSolverSettings()
            ConfigureSettingsSpecificToServiceAreaSolver()

            ConfigureGenericSolverSettings()

            UpdateContextAfterChangingSettings()
        End Sub

        Private Sub ConfigureSettingsSpecificToServiceAreaSolver()
            Dim naSASolver As INAServiceAreaSolver = TryCast(m_naContext.Solver, INAServiceAreaSolver)

            naSASolver.DefaultBreaks = ParseBreaks(txtCutOff.Text)

            naSASolver.MergeSimilarPolygonRanges = False
            naSASolver.OutputPolygons = esriNAOutputPolygonType.esriNAOutputPolygonSimplified
            naSASolver.OverlapLines = True
            naSASolver.SplitLinesAtBreaks = False
            naSASolver.TravelDirection = esriNATravelDirection.esriNATravelDirectionFromFacility
            naSASolver.OutputLines = esriNAOutputLineType.esriNAOutputLineNone
        End Sub

        Private Sub ConfigureGenericSolverSettings()
            Dim naSolverSettings As INASolverSettings = TryCast(m_naContext.Solver, INASolverSettings)
            naSolverSettings.ImpedanceAttributeName = cbCostAttribute.Text

            ' set the oneway restriction, if necessary
            Dim restrictions As IStringArray = naSolverSettings.RestrictionAttributeNames
            restrictions.RemoveAll()
            If ckbUseRestriction.Checked Then
                restrictions.Add("oneway")
            End If
            naSolverSettings.RestrictionAttributeNames = restrictions
            naSolverSettings.RestrictUTurns = esriNetworkForwardStarBacktrack.esriNFSBNoBacktrack
        End Sub

        Private Sub UpdateContextAfterChangingSettings()
            Dim datasetComponent As IDatasetComponent = TryCast(m_naContext.NetworkDataset, IDatasetComponent)
            Dim deNetworkDataset As IDENetworkDataset = TryCast(datasetComponent.DataElement, IDENetworkDataset)
            m_naContext.Solver.UpdateContext(m_naContext, deNetworkDataset, New GPMessagesClass())
        End Sub

        Private Function ParseBreaks(ByVal p As String) As IDoubleArray
            Dim breaks() As String = p.Split(" "c)
            Dim pBrks As IDoubleArray = New DoubleArrayClass()
            Dim firstIndex As Integer = breaks.GetLowerBound(0)
            Dim lastIndex As Integer = breaks.GetUpperBound(0)
            For splitIndex As Integer = firstIndex To lastIndex
                Try
                    pBrks.Add(Convert.ToDouble(breaks(splitIndex)))
                Catch e1 As FormatException
                    MessageBox.Show("Breaks are not properly formatted.  Use only digits separated by spaces")
                    pBrks.RemoveAll()
                    Return pBrks
                End Try
            Next splitIndex

            Return pBrks
        End Function

#End Region

#Region "Post-Solve"

        Private Sub LoadListboxAfterPartialSolve(ByVal gpMessages As IGPMessages)
            lbOutput.Items.Add("Partial Solve Generated.")
            For msgIndex As Integer = 0 To gpMessages.Messages.Count - 1
                Dim errorText As String = ""
                Select Case gpMessages.GetMessage(msgIndex).Type
                    Case esriGPMessageType.esriGPMessageTypeError
                        errorText = "Error " & gpMessages.GetMessage(msgIndex).ErrorCode.ToString() & " " & gpMessages.GetMessage(msgIndex).Description
                    Case esriGPMessageType.esriGPMessageTypeWarning
                        errorText = "Warning " & gpMessages.GetMessage(msgIndex).ErrorCode.ToString() & " " & gpMessages.GetMessage(msgIndex).Description
                    Case Else
                        errorText = "Information " & gpMessages.GetMessage(msgIndex).Description
                End Select
                lbOutput.Items.Add(errorText)
            Next msgIndex
        End Sub

        Private Sub DisplayOutput()
            Dim table As ITable = TryCast(m_naContext.NAClasses.ItemByName("SAPolygons"), ITable)
            If table.RowCount(Nothing) > 0 Then
                Dim gpMessage As IGPMessage = New GPMessageClass()
                lbOutput.Items.Add("FacilityID, FromBreak, ToBreak")
                Dim cursor As ICursor = table.Search(Nothing, True)
                Dim row As IRow = cursor.NextRow()
                Do While row IsNot Nothing
                    Dim facilityID As Integer = CInt(Fix(row.Value(table.FindField("FacilityID"))))
                    Dim fromBreak As Double = CDbl(row.Value(table.FindField("FromBreak")))
                    Dim toBreak As Double = CDbl(row.Value(table.FindField("ToBreak")))
                    lbOutput.Items.Add(facilityID.ToString() & ", " & fromBreak.ToString("#####0.00") & ", " & toBreak.ToString("#####0.00"))
                    row = cursor.NextRow()
                Loop
            End If
        End Sub

        Private Sub UpdateMapDisplayAfterSolve()
            ' Zoom to the extent of the service areas
            Dim geoDataset As IGeoDataset = TryCast(m_naContext.NAClasses.ItemByName("SAPolygons"), IGeoDataset)
            Dim envelope As IEnvelope = geoDataset.Extent
            If (Not envelope.IsEmpty) Then
                envelope.Expand(1.1, 1.1, True)
                axMapControl.Extent = envelope

                ' Call this to update the renderer for the service area polygons
                ' based on the new breaks.
                m_naContext.Solver.UpdateLayer(TryCast(axMapControl.get_Layer(0), INALayer))
            End If
            axMapControl.Refresh()
        End Sub

#End Region
  End Class
End Namespace