' Copyright 2008 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 use restrictions at <your ArcGIS install location>/developerkit/userestrictions.txt.
'
Option Explicit
Implements IDockableWindowDef
Private m_pApp As IApplication
Private m_pMXDoc As IMxDocument
Private WithEvents m_pMapEvent As Map ' Listen for the Map events
Private m_cResultSets As Collection 'Holds the different trace result sets
Private m_pGeomNet As IGeometricNetwork
Private m_bDrawComplex As Boolean
Private WithEvents m_AddButton As CommandButton
Private WithEvents m_RemoveButton As CommandButton
Private WithEvents m_RemoveAllButton As CommandButton
Private WithEvents m_SelectionSetButton As CommandButton
Private WithEvents m_LayerSubsetsButton As CommandButton
Private WithEvents m_PathCostButtton As CommandButton
Private WithEvents m_UpButton As CommandButton
Private WithEvents m_DownButtton As CommandButton
Private Property Get IDockableWindowDef_Caption() As String
IDockableWindowDef_Caption = "Trace Results Window"
End Property
Private Property Get IDockableWindowDef_ChildHWND() As esriSystem.OLE_HANDLE
' The dockable window will consist of a list box, so pass back the hWnd of
' the listbox on a form
IDockableWindowDef_ChildHWND = frmTraceResults.picControls.hWnd
End Property
Private Property Get IDockableWindowDef_Name() As String
IDockableWindowDef_Name = "Trace Results"
End Property
Private Sub IDockableWindowDef_OnCreate(ByVal hook As Object)
' The hook argument is a pointer to Application object.
' Establish a hook to the application
Set m_pApp = hook
Set m_pMXDoc = m_pApp.Document
If Not m_pMapEvent Is m_pMXDoc.FocusMap Then
Set m_pMapEvent = m_pMXDoc.FocusMap
End If
Set m_cResultSets = New Collection
Set m_AddButton = frmTraceResults.cmdAddLast
Set m_RemoveButton = frmTraceResults.cmdRemove
Set m_RemoveAllButton = frmTraceResults.cmdRemoveAll
Set m_SelectionSetButton = frmTraceResults.cmdSelectionSet
Set m_LayerSubsetsButton = frmTraceResults.cmdLayerSubsets
Set m_PathCostButtton = frmTraceResults.cmdPathCost
Set m_UpButton = frmTraceResults.cmdUp
Set m_DownButtton = frmTraceResults.cmdDown
End Sub
Private Sub IDockableWindowDef_OnDestroy()
Set m_pMapEvent = Nothing
Set m_pMXDoc = Nothing
Set m_pApp = Nothing
Set m_cResultSets = Nothing
Set m_pGeomNet = Nothing
Set m_AddButton = Nothing
Set m_RemoveButton = Nothing
Set m_RemoveAllButton = Nothing
Set m_SelectionSetButton = Nothing
Set m_LayerSubsetsButton = Nothing
Set m_PathCostButtton = Nothing
Set m_UpButton = Nothing
Set m_DownButtton = Nothing
End Sub
Private Property Get IDockableWindowDef_UserData() As Variant
End Property
Private Sub m_pMapEvent_AfterDraw(ByVal Display As esriDisplay.IDisplay, ByVal phase As esriCarto.esriViewDrawPhase)
On Error GoTo ErrHandler:
Dim lCount As Long, pResults As clsTraceResults
Dim pUID As New UID, pNetAnalExt As INetworkAnalysisExtResults
pUID = "esriEditorExt.UtilityNetworkAnalysisExt"
Set pNetAnalExt = m_pApp.FindExtensionByCLSID(pUID)
m_bDrawComplex = pNetAnalExt.DrawComplex
If phase = esriViewGraphics Then
If m_cResultSets.Count > 0 And frmTraceResults.lvwTraceResults.ListItems.Count = m_cResultSets.Count Then
For lCount = 1 To frmTraceResults.lvwTraceResults.ListItems.Count
If frmTraceResults.lvwTraceResults.ListItems.Item(lCount).Checked Then
Set pResults = m_cResultSets.Item(lCount)
UTIL_DrawResults Display, pResults.EdgeSet, pResults.JunctionSet, pResults.Color
End If
Next lCount
End If
End If
Exit Sub
ErrHandler:
MsgBox "m_pMap_AfterDraw - " & Erl & " - " & Err.Description
End Sub
Private Function UTIL_GetLayer(pFeatClass As IFeatureClass, pVisibilityCheck As Boolean) As IFeatureLayer
'Routine for returning a feature layer based on a feature class, if pVisibilityCheck
'is true, then only return the layer when it is visible
On Error GoTo ErrHandler:
Dim pDoc As IMxDocument, iLoop As Integer
Dim pMap As IMap
Dim pFLayer As IFeatureLayer
Set pDoc = m_pApp.Document
Set pMap = pDoc.FocusMap
Set UTIL_GetLayer = Nothing
For iLoop = 0 To pMap.LayerCount - 1
If TypeOf pMap.Layer(iLoop) Is IFeatureLayer Then
Set pFLayer = pMap.Layer(iLoop)
If ObjPtr(pFLayer.FeatureClass) = ObjPtr(pFeatClass) Then
If pVisibilityCheck Then
If pMap.Layer(iLoop).Visible Then
Set UTIL_GetLayer = pFLayer
Else
Set UTIL_GetLayer = Nothing
End If
Else
Set UTIL_GetLayer = pFLayer
End If
Exit For
End If
End If
Next iLoop
Exit Function
ErrHandler:
MsgBox "Util_GetLayer - " & Err.Description
Exit Function
End Function
Public Sub UTIL_DrawResults(pDisplay As IDisplay, pEdgeSet As IEnumNetEID, pJuncSet As IEnumNetEID, pColor As IColor)
'Routine for drawing the results of a trace
On Error GoTo ErrHand:
'Only display results (do not create selection set)
If m_pGeomNet Is Nothing Then Exit Sub
Dim pFeatureClass As IFeatureClass, pEnumFC As IEnumFeatureClass
'Draw Complex Edges
Set pEnumFC = m_pGeomNet.ClassesByType(esriFTComplexEdge)
Set pFeatureClass = pEnumFC.Next
While Not pFeatureClass Is Nothing
If Not UTIL_GetLayer(pFeatureClass, True) Is Nothing Then
UTIL_DrawLayer pEdgeSet, pFeatureClass, True, pDisplay, esriFTComplexEdge, pColor
End If
Set pFeatureClass = pEnumFC.Next
Wend
'Draw Simple Edges
Set pEnumFC = m_pGeomNet.ClassesByType(esriFTSimpleEdge)
Set pFeatureClass = pEnumFC.Next
While Not pFeatureClass Is Nothing
If Not UTIL_GetLayer(pFeatureClass, True) Is Nothing Then
UTIL_DrawLayer pEdgeSet, pFeatureClass, True, pDisplay, esriFTSimpleEdge, pColor
End If
Set pFeatureClass = pEnumFC.Next
Wend
'Draw Simple Junctions
Set pEnumFC = m_pGeomNet.ClassesByType(esriFTSimpleJunction)
Set pFeatureClass = pEnumFC.Next
While Not pFeatureClass Is Nothing
If Not UTIL_GetLayer(pFeatureClass, True) Is Nothing Then
UTIL_DrawLayer pJuncSet, pFeatureClass, True, pDisplay, esriFTSimpleJunction, pColor
End If
Set pFeatureClass = pEnumFC.Next
Wend
Exit Sub
ErrHand:
MsgBox "UTIL_DrawResults - " & Err.Description
Exit Sub
End Sub
Private Sub UTIL_DrawLayer(pSelection As IEnumNetEID, pFeatureClass As IFeatureClass, _
needDuplicates As Boolean, pDisplay As IDisplay, pFeatType As esriFeatureType, pColor As IColor)
'Routine for drawing the layers in the result set of a trace
'
'Layers are drawn by generating a whereclause containing the OIDs of the features in the trace
'results. The whereclause is then sent to UTIL_DrawFeatures to select the features and
'display them.
On Error GoTo ErrHand:
Dim whereClause As String, featureCount As Long, pNetwork As INetwork
Dim firstTime As Boolean, pNetElements As INetElements
Dim pClassID As Long, elementEID As Long
Dim pUserClassID As Long, pUserID As Long, pUserSubID As Long
Set pNetwork = m_pGeomNet.Network
featureCount = 0
firstTime = True
Set pNetElements = pNetwork
pClassID = pFeatureClass.FeatureClassID
pSelection.Reset
elementEID = pSelection.Next
'Determine the layer name for use in the where clause
Dim pDataset As IDataset, sLayerName As String
Set pDataset = pFeatureClass
sLayerName = pDataset.Name
If pDataset.Workspace.Type = esriRemoteDatabaseWorkspace Then
If InStr(1, sLayerName, ".", vbTextCompare) > 0 Then
sLayerName = Mid(sLayerName, InStr(1, sLayerName, ".", vbTextCompare) + 1) + "."
End If
Else
sLayerName = ""
End If
'Loop through the elements, determine and saving the feature ID of each
Dim elementType As esriElementType, pApp As IApplication
Dim pDoc As IMxDocument, pDrawComplex As Boolean
Set pDoc = m_pApp.Document
While elementEID <> 0
If pFeatType = esriFTComplexEdge Or pFeatType = esriFTSimpleEdge Then
pNetElements.QueryIDs elementEID, esriETEdge, pUserClassID, pUserID, pUserSubID
Else
pNetElements.QueryIDs elementEID, esriETJunction, pUserClassID, pUserID, pUserSubID
End If
If pClassID = pUserClassID Then
'Determine whether to draw complex features by their elements or not
Select Case pFeatType
Case esriFTComplexJunction
pDrawComplex = True
Case esriFTComplexEdge
If m_bDrawComplex Then
pDrawComplex = True
Else
pDrawComplex = False
End If
Case Else
pDrawComplex = False
End Select
If pDrawComplex Then
' if we are looking at a complex edge, then we need to draw it independently
' to make sure we draw only the elements of the edge that were traced
Dim pLineSymbol As ISimpleLineSymbol
Set pLineSymbol = UTIL_CreateLineSymbol(255, 255, 0, 2)
If elementType = esriETEdge Then
Dim pNetworkFeature As INetworkFeature
Set pNetworkFeature = pFeatureClass.GetFeature(pUserID)
'Check to see if current feature is within the current extent envelope
Dim theEnv As IEnvelope, pFeat As IFeature
Set theEnv = New Envelope
theEnv.XMin = pDoc.ActiveView.Extent.XMin
theEnv.XMax = pDoc.ActiveView.Extent.XMax
theEnv.YMin = pDoc.ActiveView.Extent.YMin
theEnv.YMax = pDoc.ActiveView.Extent.YMax
Set pFeat = pNetworkFeature
theEnv.Intersect pFeat.Extent
If Not theEnv.IsEmpty Then
Dim pGeometry As IGeometry, pEdgeFeat
Set pEdgeFeat = pNetworkFeature
Set pGeometry = pEdgeFeat.GeometryForEdgeElement(pUserSubID)
pLineSymbol.Color = pColor
End If
End If
Else
'Simple features
If firstTime = True Then
whereClause = sLayerName & pFeatureClass.OIDFieldName & " in ( " & pUserID
firstTime = False
Else
whereClause = whereClause & "," & pUserID
End If
featureCount = featureCount + 1
If featureCount > 500 Then
whereClause = whereClause + ")"
UTIL_DrawFeatures pFeatureClass, whereClause, pDisplay, pColor
featureCount = 0
firstTime = True
End If
End If
End If
elementEID = pSelection.Next
Wend
If featureCount > 0 Then
whereClause = whereClause + ")"
UTIL_DrawFeatures pFeatureClass, whereClause, pDisplay, pColor
End If
Exit Sub
ErrHand:
MsgBox "UTIL_DrawLayer - " & Err.Description
Exit Sub
End Sub
Private Sub UTIL_DrawFeatures(pFeatureClass As IFeatureClass, whereClause As String, _
pDisplay As IDisplay, pColor As IColor)
'Routine for drawing the individual features in the result set of a trace
On Error GoTo ErrHand:
'Select the feature to draw based on a query of the OIDs found in UTIL_DrawLayer
Dim pFilter As ISpatialFilter, pApp As IApplication, pDoc As IMxDocument
Set pApp = m_pApp
Set pFilter = New SpatialFilter
pFilter.whereClause = whereClause
pFilter.SubFields = pFeatureClass.ShapeFieldName & ", " & pFeatureClass.OIDFieldName
pFilter.GeometryField = pFeatureClass.ShapeFieldName
Set pDoc = pApp.Document
Set pFilter.Geometry = pDoc.ActiveView.Extent
pFilter.SpatialRel = esriSpatialRelEnvelopeIntersects
Dim pFeatureCursor As IFeatureCursor
Set pFeatureCursor = pFeatureClass.Search(pFilter, True)
Dim pLineSymbol As ISimpleLineSymbol
Set pLineSymbol = UTIL_CreateLineSymbol(255, 255, 0, 2)
pLineSymbol.Color = pColor
Dim pMarkerSymbol As ISimpleMarkerSymbol
Set pMarkerSymbol = UTIL_CreateMarkerSymbol(255, 255, 0, esriSMSCircle, 6)
pMarkerSymbol.Color = pColor
'Loop through the cursor drawing the features that were found
Dim pGeometry As IGeometry, pFeature As IFeature
If Not pFeatureCursor Is Nothing Then
Set pFeature = pFeatureCursor.NextFeature
While Not pFeature Is Nothing
Set pGeometry = pFeature.Shape
Select Case pFeatureClass.FeatureType
Case esriFTSimpleEdge
pDisplay.SetSymbol pLineSymbol
pDisplay.DrawPolyline pGeometry
Case esriFTComplexEdge
If m_bDrawComplex Then
Else
pDisplay.SetSymbol pLineSymbol
pDisplay.DrawPolyline pGeometry
End If
Case esriFTSimpleJunction
pDisplay.SetSymbol pMarkerSymbol
pDisplay.DrawPoint pGeometry
End Select
Set pFeature = pFeatureCursor.NextFeature
Wend
End If
Exit Sub
ErrHand:
MsgBox "UTIL_DrawFeatures - " & Err.Description
Exit Sub
End Sub
Public Sub UTIL_MakeSelectionSets(lCount As Long)
'Routine for converting a trace result set into a selection set
On Error GoTo ErrHand:
'If the "Create selection set" option is turned on
Dim pWork As IWorkspace
Dim pNetElems As INetElements
Set pWork = m_pGeomNet.FeatureDataset.Workspace
Set pNetElems = m_pGeomNet.Network
Dim pLayer As ILayer, iLoop As Integer
Dim pFLayer As IFeatureLayer
Dim pDoc As IMxDocument
Dim pMap As IMap
Dim pFDataset As IFeatureDataset
Dim pGeomNetwork As IGeometricNetwork
Dim pSelEvents As ISelectionEvents
Set pDoc = m_pApp.Document
Set pMap = pDoc.FocusMap
'Clear the current selection
pMap.ClearSelection
Dim fcCount As Long, pFeatureClass As IFeatureClass, pNetClass As INetworkClass
Dim pFCContainer As IFeatureClassContainer, pAllColl As New Collection, pEIDColl As Collection
Dim lLoop As Long, lEIDs() As Long
Set pFDataset = m_pGeomNet.FeatureDataset
If pFDataset Is Nothing Then Exit Sub
Set pFCContainer = pFDataset
fcCount = pFCContainer.ClassCount
'Open a collection on each network layer so that we can add select OIDs to it. Collections are
'used because they are quicker than adding directly to the selection set. When you add an OID
'to a collection it will check to make sure they OID is already present.
For iLoop = 0 To pMap.LayerCount - 1
Set pLayer = pMap.Layer(iLoop)
If TypeOf pLayer Is IFeatureLayer Then
Set pFLayer = pLayer
Set pFeatureClass = pFLayer.FeatureClass
If TypeOf pFeatureClass Is INetworkClass Then
Set pNetClass = pFeatureClass
If Not pNetClass.GeometricNetwork Is Nothing Then
Set pGeomNetwork = pNetClass.GeometricNetwork
If pFDataset.Name = pGeomNetwork.FeatureDataset.Name Then
Set pEIDColl = New Collection
pAllColl.Add pEIDColl, CStr(pFeatureClass.FeatureClassID)
End If
Set pGeomNetwork = Nothing
End If
End If
End If
Next iLoop
Dim pJuncSet As IEnumNetEID, pEdgeSet As IEnumNetEID, pResults As clsTraceResults
Set pResults = m_cResultSets.Item(lCount)
Set pJuncSet = pResults.JunctionSet
Set pEdgeSet = pResults.EdgeSet
pJuncSet.Reset
pEdgeSet.Reset
Dim elementEID As Long, elementOID As Long, elementClassID As Long, elementSub As Long
Dim pMyColl As Collection
'Transfer the list of selected EID to the collection for each layer
elementEID = pJuncSet.Next
While elementEID <> 0
pNetElems.QueryIDs elementEID, esriETJunction, elementClassID, elementOID, elementSub
Set pMyColl = pAllColl.Item(CStr(elementClassID))
On Error GoTo Skip:
pMyColl.Add elementOID, CStr(elementOID)
On Error GoTo ErrHand:
elementEID = pJuncSet.Next
Wend
elementEID = pEdgeSet.Next
While elementEID <> 0
pNetElems.QueryIDs elementEID, esriETEdge, elementClassID, elementOID, elementSub
Set pMyColl = pAllColl.Item(CStr(elementClassID))
On Error GoTo Skip:
pMyColl.Add elementOID, CStr(elementOID)
On Error GoTo ErrHand:
elementEID = pEdgeSet.Next
Wend
'Convert the collections to an array and then add the array as a list (AddList) to the
'selection set for each layer.
Dim pFeatureSelection As IFeatureSelection
For iLoop = 0 To pMap.LayerCount - 1
Set pLayer = pMap.Layer(iLoop)
If TypeOf pLayer Is IFeatureLayer Then
Set pFLayer = pLayer
Set pFeatureClass = pFLayer.FeatureClass
If TypeOf pFeatureClass Is INetworkClass And pFLayer.Selectable Then
Set pNetClass = pFeatureClass
If Not pNetClass.GeometricNetwork Is Nothing Then
Set pGeomNetwork = pNetClass.GeometricNetwork
If pFDataset.Name = pGeomNetwork.FeatureDataset.Name Then
Set pMyColl = pAllColl.Item(CStr(pFeatureClass.FeatureClassID))
If pMyColl.Count > 0 Then
ReDim lEIDs(pMyColl.Count - 1)
For lLoop = 0 To pMyColl.Count - 1
lEIDs(lLoop) = pMyColl.Item(lLoop + 1)
Next lLoop
Set pFeatureSelection = pFLayer
pFeatureSelection.SelectionSet.AddList pMyColl.Count, lEIDs(0)
End If
End If
End If
End If
End If
Next iLoop
'Refresh the display and fire the selectionchanged event
pDoc.ActiveView.Refresh
Set pSelEvents = pDoc.FocusMap
pSelEvents.SelectionChanged
Exit Sub
Skip: 'Called when a duplicate OID is found with QueryIDs
Resume Next
ErrHand:
MsgBox "UTIL_MakeSelectionSets - " & Erl & " - " & Err.Description
Exit Sub
End Sub
Public Function UTIL_CreateLineSymbol(lRed As Long, lGreen As Long, lBlue As Long, _
Optional dWidth, Optional rop2, Optional style) As ISimpleLineSymbol
'Routine for creating a line symbol to display the trace results
Dim pLineSymbol As ISimpleLineSymbol
Set pLineSymbol = New SimpleLineSymbol
Dim pColor As IRgbColor
Set pColor = New RgbColor
With pColor
.Red = lRed
.Green = lGreen
.Blue = lBlue
End With
pLineSymbol.Color = pColor
If Not IsMissing(dWidth) Then
pLineSymbol.Width = dWidth
End If
If Not IsMissing(rop2) Then
Dim pSymbol As ISymbol
Set pSymbol = pLineSymbol
pSymbol.rop2 = rop2
End If
If Not IsMissing(style) Then
pLineSymbol.style = style
End If
Set UTIL_CreateLineSymbol = pLineSymbol
End Function
Public Function UTIL_CreateMarkerSymbol(lRed As Long, lGreen As Long, lBlue As Long, _
Optional style, Optional dSize, Optional rop2) As ISimpleMarkerSymbol
'Routine for creating a marker symbol for displaying the results of a trace
Dim pPtSym As ISimpleMarkerSymbol
Set pPtSym = New SimpleMarkerSymbol
Dim pColor As IRgbColor
Set pColor = New RgbColor
With pColor
.Red = lRed
.Blue = lBlue
.Green = lGreen
End With
pPtSym.Color = pColor
If Not IsMissing(style) Then
pPtSym.style = style
End If
If Not IsMissing(dSize) Then
pPtSym.Size = dSize
End If
If Not IsMissing(rop2) Then
Dim pSymbol As ISymbol
Set pSymbol = pPtSym
pSymbol.rop2 = rop2
End If
Set UTIL_CreateMarkerSymbol = pPtSym
End Function
Private Sub m_AddButton_Click()
On Error GoTo ErrHand:
'Save the results in the results collection
Dim pResults As New clsTraceResults, lIndex As Long
Dim pUID As New UID, pNetUtil As IUtilityNetworkAnalysisExt
Dim pTasks As ITraceTasks, pTraceResults As ITraceTaskResults
Dim pNetAnalExt As INetworkAnalysisExt, pNetAnalExtColor As INetworkAnalysisExtResultColor
Dim pPathResults As ITracePathTaskResults, pNetResults As INetworkAnalysisExtResults
pUID = "esriEditorExt.UtilityNetworkAnalysisExt"
Set pNetUtil = m_pApp.FindExtensionByCLSID(pUID)
Set pTasks = pNetUtil
If pTasks.CurrentTask Is Nothing Then
MsgBox "There is no current Trace Task!!"
Exit Sub
End If
Set pTraceResults = pTasks.CurrentTask
'Check for something in the results
If pTraceResults.ResultEdges Is Nothing Then
MsgBox "There are no trace results!!!"
Exit Sub
End If
Set pNetAnalExtColor = pNetUtil
Set pResults.EdgeSet = pTraceResults.ResultEdges
Set pResults.JunctionSet = pTraceResults.ResultJunctions
Set pResults.Color = pNetAnalExtColor.Color
If TypeOf pTraceResults Is ITracePathTaskResults Then
Set pPathResults = pTraceResults
pResults.PathCost = pPathResults.TotalCost
Else
pResults.PathCost = 0
End If
m_cResultSets.Add pResults
lIndex = frmTraceResults.lvwTraceResults.ListItems.Count + 1
frmTraceResults.lvwTraceResults.ListItems.Add lIndex, , pTasks.CurrentTask.Name
frmTraceResults.lvwTraceResults.ListItems.Item(lIndex).Checked = True
frmTraceResults.lvwTraceResults.ListItems.Item(lIndex).ForeColor = pResults.Color.RGB
Set pNetAnalExt = pNetUtil
Set m_pGeomNet = pNetAnalExt.CurrentNetwork
'Clear the results from the Utility Network Analysis toolbar (since the results will now draw through
'this tool/extension.
Set pNetResults = pNetAnalExtColor
pNetResults.ClearResults
Exit Sub
ErrHand:
MsgBox "m_AddButton_Click - " & Erl & " - " & Err.Description
End Sub
Private Sub m_LayerSubsetsButton_Click()
On Error GoTo ErrHand:
Dim lIndex As Long, lLoop As Long, pFLayer As IFeatureLayer
Dim pFeatSel As IFeatureSelection, pNewFLayer As IFeatureLayer
Dim pGeoFLayer As IGeoFeatureLayer, pNewGeoFLayer As IGeoFeatureLayer
Dim pDoc As IMxDocument, pFLDef As IFeatureLayerDefinition
Dim pMap As IMap
Dim pGLayer As IGroupLayer, pGroup As ILayer
If frmTraceResults.lvwTraceResults.ListItems.Count = 0 Then Exit Sub
Set pDoc = m_pApp.Document
Set pMap = pDoc.FocusMap
lIndex = frmTraceResults.lvwTraceResults.SelectedItem.Index
'First create the selections based on the selected trace
UTIL_MakeSelectionSets lIndex
'Create a new group layer to hold the selection layers
Set pGroup = New GroupLayer
pGroup.Name = frmTraceResults.lvwTraceResults.ListItems.Item(lIndex).Text & " Results"
Set pGLayer = pGroup
'Loop through the layers and find the ones with selection sets. Create new layers from these.
'Also turn off the display of each layer as you go.
For lLoop = 0 To pMap.LayerCount - 1
pMap.Layer(lLoop).Visible = False
If TypeOf pMap.Layer(lLoop) Is IFeatureLayer Then
Set pFLayer = pMap.Layer(lLoop)
Set pFeatSel = pFLayer
If pFeatSel.SelectionSet.Count > 0 Then
Set pFLDef = pFLayer
Set pGeoFLayer = pFLayer
Set pNewFLayer = pFLDef.CreateSelectionLayer(pFLayer.Name & "_1", True, "", "")
Set pNewGeoFLayer = pNewFLayer
Set pNewGeoFLayer.Renderer = pGeoFLayer.Renderer
pGLayer.Add pNewFLayer
End If
End If
Next lLoop
pMap.AddLayer pGLayer
pDoc.ActiveView.Refresh
Exit Sub
ErrHand:
MsgBox "m_LayerSubsetsButton_Click - " & Erl & " - " & Err.Description
End Sub
Private Sub m_PathCostButtton_Click()
On Error GoTo ErrHand:
Dim lIndex As Long, pResults As clsTraceResults
If frmTraceResults.lvwTraceResults.ListItems.Count = 0 Then Exit Sub
lIndex = frmTraceResults.lvwTraceResults.SelectedItem.Index
Set pResults = m_cResultSets.Item(lIndex)
If pResults.PathCost = 0 Then
MsgBox "Path Cost can only be shown for Trace Path results!!!"
Else
MsgBox "Path Cost: " & CStr(pResults.PathCost)
End If
Exit Sub
ErrHand:
MsgBox "m_PathCostButtton_Click - " & Erl & " - " & Err.Description
End Sub
Private Sub m_RemoveAllButton_Click()
Set m_cResultSets = New Collection
frmTraceResults.lvwTraceResults.ListItems.Clear
End Sub
Private Sub m_RemoveButton_Click()
On Error GoTo ErrHand:
Dim lIndex As Long
If frmTraceResults.lvwTraceResults.ListItems.Count = 0 Then Exit Sub
lIndex = frmTraceResults.lvwTraceResults.SelectedItem.Index
m_cResultSets.Remove lIndex
frmTraceResults.lvwTraceResults.ListItems.Remove lIndex
Exit Sub
ErrHand:
MsgBox "m_RemoveButton_Click - " & Erl & " - " & Err.Description
End Sub
Private Sub m_SelectionSetButton_Click()
On Error GoTo ErrHand:
Dim lIndex As Long
If frmTraceResults.lvwTraceResults.ListItems.Count = 0 Then Exit Sub
lIndex = frmTraceResults.lvwTraceResults.SelectedItem.Index
UTIL_MakeSelectionSets lIndex
Exit Sub
ErrHand:
MsgBox "m_SelectionSetButton_Click - " & Erl & " - " & Err.Description
End Sub
Private Sub m_UpButton_Click()
On Error GoTo ErrHand:
Dim lIndex As Long, pResults As clsTraceResults, sName As String
If frmTraceResults.lvwTraceResults.ListItems.Count = 0 Then Exit Sub
lIndex = frmTraceResults.lvwTraceResults.SelectedItem.Index
If lIndex = 1 Then Exit Sub
Set pResults = m_cResultSets.Item(lIndex)
sName = frmTraceResults.lvwTraceResults.ListItems.Item(lIndex).Text
'Remove it
m_cResultSets.Remove lIndex
frmTraceResults.lvwTraceResults.ListItems.Remove lIndex
'Add it back at new position
m_cResultSets.Add pResults, , lIndex - 1
frmTraceResults.lvwTraceResults.ListItems.Add lIndex - 1, , sName
frmTraceResults.lvwTraceResults.ListItems.Item(lIndex - 1).Checked = True
frmTraceResults.lvwTraceResults.ListItems.Item(lIndex - 1).ForeColor = pResults.Color.RGB
Exit Sub
ErrHand:
MsgBox "m_UpButton_Click - " & Erl & " - " & Err.Description
End Sub
Private Sub m_DownButtton_Click()
On Error GoTo ErrHand:
Dim lIndex As Long, pResults As clsTraceResults, sName As String
If frmTraceResults.lvwTraceResults.ListItems.Count = 0 Then Exit Sub
lIndex = frmTraceResults.lvwTraceResults.SelectedItem.Index
If lIndex = frmTraceResults.lvwTraceResults.ListItems.Count Then Exit Sub
Set pResults = m_cResultSets.Item(lIndex)
sName = frmTraceResults.lvwTraceResults.ListItems.Item(lIndex).Text
'Remove it
m_cResultSets.Remove lIndex
frmTraceResults.lvwTraceResults.ListItems.Remove lIndex
'Add it back at new position
m_cResultSets.Add pResults, , , lIndex
frmTraceResults.lvwTraceResults.ListItems.Add lIndex + 1, , sName
frmTraceResults.lvwTraceResults.ListItems.Item(lIndex + 1).Checked = True
frmTraceResults.lvwTraceResults.ListItems.Item(lIndex + 1).ForeColor = pResults.Color.RGB
Exit Sub
ErrHand:
MsgBox "m_DownButtton_Click - " & Erl & " - " & Err.Description
End Sub