featureselect.txt

VB+AO用于地理信息系统二次开发 该部分代码用于实现对地图要素进行选择

Option Explicit

Private m_pBitmap As IPictureDisp
Private m_pCursor As IPictureDisp
Private m_pSceneHookhelper As ISceneHookHelper
Private m_bInUse As Boolean

Implements ICommand
Implements ITool

Private Sub Class_Initialize()
  Set m_pSceneHookhelper = New SceneHookHelper
  Set m_pBitmap = LoadResPicture("SelectFeatures", vbResBitmap)
  Set m_pCursor = LoadResPicture("SelectFeatures", vbResCursor)
End Sub

Private Sub Class_Terminate()
  Set m_pSceneHookhelper = Nothing
  Set m_pBitmap = Nothing
  Set m_pCursor = Nothing
End Sub

Private Property Get ICommand_Bitmap() As esriSystem.OLE_HANDLE
  ICommand_Bitmap = m_pBitmap
End Property

Private Property Get ICommand_Caption() As String
 ICommand_Caption = "SelectFeatures"
End Property

Private Property Get ICommand_Category() As String
  ICommand_Category = "Sample_SceneControl"
End Property

Private Property Get ICommand_Checked() As Boolean
  ICommand_Checked = False
End Property

Private Property Get ICommand_Enabled() As Boolean
  
  If m_pSceneHookhelper.hook Is Nothing Or m_pSceneHookhelper.Scene Is Nothing Then
    ICommand_Enabled = False
  Else
    Dim pScene As IScene
    Set pScene = m_pSceneHookhelper.Scene
    
    'Disable if no layer
    If pScene.LayerCount = 0 Then ICommand_Enabled = False
    'Enable if any selectable layers
    Dim bSelectable As Boolean
    bSelectable = False
    
    Dim pEnumLayer As IEnumLayer
    Set pEnumLayer = pScene.Layers
    pEnumLayer.Reset
    
    Dim pLayer As ILayer
    Set pLayer = pEnumLayer.Next
  
    'Loop through the scene layers
    Do Until pLayer Is Nothing
      'Determine if there is a selectable feature layer
      If TypeOf pLayer Is IFeatureLayer Then
        Dim pFeatureLayer As IFeatureLayer
        Set pFeatureLayer = pLayer
        If pFeatureLayer.Selectable = True Then
          bSelectable = True
          Exit Do
        End If
      End If
      Set pLayer = pEnumLayer.Next
    Loop
    ICommand_Enabled = bSelectable
  End If
End Property

Private Property Get ICommand_HelpContextID() As Long
  'Not implemented
End Property

Private Property Get ICommand_HelpFile() As String
  'Not implemented
End Property

Private Property Get ICommand_Message() As String
   ICommand_Message = "Select features by clicking"
End Property

Private Property Get ICommand_Name() As String
  ICommand_Name = "Sample_SceneControl/SelectFeatures"
End Property

Private Sub ICommand_OnClick()
  'Not implemented
End Sub

Private Sub ICommand_OnCreate(ByVal hook As Object)
  Set m_pSceneHookhelper.hook = hook
End Sub

Private Property Get ICommand_Tooltip() As String
  ICommand_Tooltip = "Select Features"
End Property

Private Property Get ITool_Cursor() As esriSystem.OLE_HANDLE
    ITool_Cursor = m_pCursor
End Property

Private Function ITool_Deactivate() As Boolean
  ITool_Deactivate = True
End Function

Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean
  'Not implemented
End Function

Private Sub ITool_OnDblClick()
  'Not implemented
End Sub

Private Sub ITool_OnKeyDown(ByVal keyCode As Long, ByVal Shift As Long)
  'Not implemented
End Sub

Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long)
  'Not implemented
End Sub

Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
  'Not implemented
End Sub

Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
  'Not implemented
End Sub

Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
  
  'Get the scene graph
  Dim pSceneGraph As ISceneGraph
  Set pSceneGraph = m_pSceneHookhelper.SceneGraph
  
  'Get the scene
  Dim pScene As IScene
  Set pScene = m_pSceneHookhelper.Scene
  
  Dim pPoint As IPoint
  Dim pOwner As IUnknown
  Dim pObject As IUnknown
  'Translate screen coordinates into a 3D point
  pSceneGraph.Locate pSceneGraph.ActiveViewer, X, Y, esriScenePickGeography, True, pPoint, pOwner, pObject

  'Get a selection environment
  Dim pSelectionEnv As ISelectionEnvironment
  Set pSelectionEnv = New SelectionEnvironment
  If Shift = 0 Then
    pSelectionEnv.CombinationMethod = esriSelectionResultNew
    'Clear previous selection
    If pOwner Is Nothing Then
      pScene.ClearSelection
      Exit Sub
    End If
  Else
    pSelectionEnv.CombinationMethod = esriSelectionResultAdd
  End If
  
  'If the layer is a selectable feature layer
  If TypeOf pOwner Is IFeatureLayer Then
    Dim pFeatureLayer As IFeatureLayer
    Set pFeatureLayer = pOwner
    If pFeatureLayer.Selectable = True Then
      'Select by shape
      pScene.SelectByShape pPoint, pSelectionEnv, False
    End If
  End If
  
  'Refresh the scene viewer
  pSceneGraph.RefreshViewers

End Sub

Private Sub ITool_Refresh(ByVal hdc As esriSystem.OLE_HANDLE)
  'Not implemented
End Sub