frmquery.frm

ArcEngine 这是基于AE组件的源代码

  ' if a feature was found within search tolerance return it
  ' in order of geometry priority
  If (Not pPointFeature Is Nothing) Then
    Set pFeature = pPointFeature
    removeIndex = pointRemoveIndex
  ElseIf (Not pLineFeature Is Nothing) Then
    Set pFeature = pLineFeature
    removeIndex = lineRemoveIndex
  ElseIf (Not pAreaFeature Is Nothing) Then
    Set pFeature = pAreaFeature
    removeIndex = areaRemoveIndex
  End If
  
  Exit Sub
ErrorHandler:
  MsgBox "An unexpected error has occured with the Selection Dialog." & vbCr & vbCr & _
         "Details : " & Err.Description, vbExclamation + vbOKOnly, "Error"
End Sub

Private Sub GetNearestObject(pSearchEnvelope As IEnvelope, pFeature As iFeature)
  Dim i As Integer
  Dim player As ILayer
  Dim pFeatureLayer As IGeoFeatureLayer
  Dim pFilter  As ISpatialFilter
  Dim pSearchGeometry As IGeometry
  Dim shapefield As String
  Dim pCursor As IFeatureCursor
  Dim pSelectionColn As Collection
  Dim pFeatureClass As IFeatureClass
  Dim pPoint As IPoint
  
  On Error GoTo ErrorHandler
  
  ' Search for features within the database
  
  Set pSelectionColn = New Collection
  For i = 0 To (m_pMap.LayerCount - 1)
    Set pFeatureLayer = m_pMap.Layer(i)
    Set pFeatureClass = pFeatureLayer.FeatureClass
    Set pFilter = New SpatialFilter
  
    pFilter.SpatialRel = esriSpatialRelIntersects
    Set pSearchGeometry = pSearchEnvelope
    Set pFilter.Geometry = pSearchGeometry
    shapefield = pFeatureClass.ShapeFieldName
    pFilter.GeometryField = shapefield
    Set pFilter.OutputSpatialReference(shapefield) = m_pMap.SpatialReference
    Set pCursor = pFeatureLayer.Search(pFilter, False)
    Do
      Set pFeature = pCursor.NextFeature
      
      If (Not pFeature Is Nothing) Then pSelectionColn.Add pFeature
    Loop While (Not pFeature Is Nothing)
  Next i
  
  ' We have performed the selection, but we now must find the closest object
  Set pFeature = Nothing
  If (pSelectionColn.count > 0) Then
    Set pPoint = New Point
    pPoint.x = pSearchEnvelope.xmin + (pSearchEnvelope.Width / 2)
    pPoint.y = pSearchEnvelope.ymin + (pSearchEnvelope.Height / 2)
    GetClosestFeatureInCollection pSelectionColn, pPoint, pFeature
  End If

  Set pSelectionColn = Nothing
  
  Exit Sub
ErrorHandler:
  MsgBox "An unexpected error has occured with the Selection Dialog." & vbCr & vbCr & _
         "Details : " & Err.Description, vbExclamation + vbOKOnly, "Error"
End Sub

Private Sub GiveWarning(title As String, warning As String)
  Beep
  MsgBox warning, vbOKOnly + vbExclamation, title
End Sub

Private Function FoundLayer(name As String, pFeatureLayer As IFeatureLayer) As Boolean
Dim i As Long
  Set pFeatureLayer = Nothing
  For i = 0 To (m_pMap.LayerCount - 1)
    Debug.Print "1. " & name
    Debug.Print "2." & m_pMap.Layer(i).name
    If (m_pMap.Layer(i).name = name) Then
      Set pFeatureLayer = m_pMap.Layer(i)
      FoundLayer = True
      Exit Function
    End If
  Next i
  FoundLayer = False
End Function

Private Sub QueryByClass(operator As esriSelectionResultEnum)
  Dim pFeatureLayer As IGeoFeatureLayer
  Dim j As Long
  Dim pFeatureselection As IFeatureSelection
  Dim pActiveView As IActiveView
  
  On Error GoTo ErrorHandler
  
  Set pActiveView = m_pMap
  pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
  For j = 0 To lstClass.ListCount - 1
    If (lstClass.Selected(j)) Then
      If (FoundLayer(lstClass.List(j), pFeatureLayer)) Then
        Set pFeatureselection = pFeatureLayer
        If (pFeatureLayer.Selectable) Then
          pFeatureselection.SelectFeatures Nothing, operator, False
        Else
          If (operator = esriSelectionResultNew) Then pFeatureselection.Clear
        End If
      End If
    Else
      If (FoundLayer(lstClass.List(j), pFeatureLayer)) Then
        Set pFeatureselection = pFeatureLayer
        If ((operator = esriSelectionResultNew) Or _
            (operator = esriSelectionResultAnd)) Then pFeatureselection.Clear
      End If
    End If
  Next j
  pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
  frmMDIMain.ActiveBar.Bands("StatusBar").Tools("StatusBarLabel").Caption = "选择实体的数目: " & CStr(m_pMap.SelectionCount)
  RefreshSelectButtons
  
  Exit Sub
ErrorHandler:
  MsgBox "An unexpected error has occured with the Selection Dialog." & vbCr & vbCr & _
         "Details : " & Err.Description, vbExclamation + vbOKOnly, "Error"
End Sub

Private Sub QueryByAttribute(operator As esriSelectionResultEnum)
  Dim pFeatureLayer As IGeoFeatureLayer
  Dim j As Long
  Dim i As Long
  Dim pFeatureselection As IFeatureSelection
  Dim pActiveView As IActiveView
  Dim pFields As IFields
  Dim pField As IField
  Dim FieldID As Long
  Dim operatorString As String
  Dim whereClause As String
  Dim pFilter As IQueryFilter
  Dim attName As String
  Dim attValue As Variant
  
  On Error GoTo ErrorHandler
  
  ' construct the where clause from the users entries on the form
  If ((lstAttribute.SelCount < 1) Or (txtValue = "")) Then
    GiveWarning "Warning", "You must select an attribute along with a value!"
    Exit Sub
  End If
  
  For i = 0 To lstAttribute.ListCount - 1
    If (lstAttribute.Selected(i)) Then
      attName = lstAttribute.List(i)
      i = lstAttribute.ListCount
    End If
  Next i
  
  Select Case cboOperator.Text
    Case "等于"
      operatorString = "="
    Case "不等于"
      operatorString = "<>"
    Case "小于"
      operatorString = "<"
    Case "大于"
      operatorString = ">"
    Case "小于或等于"
      operatorString = "<="
    Case "大于或等于"
      operatorString = ">="
  End Select
  
  Set pActiveView = m_pMap
  pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
  For j = 0 To lstClass.ListCount - 1
    If (lstClass.Selected(j)) Then
      If (FoundLayer(lstClass.List(j), pFeatureLayer)) Then
        Set pFeatureselection = pFeatureLayer
        If (pFeatureLayer.Selectable) Then
          ' Must convert the attribute value to the correct type
          Set pFields = pFeatureLayer.FeatureClass.Fields
          FieldID = pFeatureLayer.FeatureClass.FindField(attName)
          Set pField = pFields.Field(FieldID)
          attValue = txtValue.Text
          Select Case pField.Type
            Case esriFieldTypeInteger
              attValue = CInt(attValue)
            Case esriFieldTypeSingle
              attValue = CInt(attValue)
            Case esriFieldTypeSmallInteger
              attValue = CInt(attValue)
            Case esriFieldTypeDouble
              attValue = CDbl(attValue)
            Case esriFieldTypeOID
              attValue = CLng(attValue)
            Case esriFieldTypeString
              attValue = CStr(attValue)
              attValue = "'" & CStr(attValue) & "'"
          End Select
          whereClause = attName & operatorString & " " & CStr(attValue)
          Set pFilter = New QueryFilter
          pFilter.SubFields = "*"
          pFilter.whereClause = whereClause
          Set pFilter.OutputSpatialReference(attName) = m_pMap.SpatialReference
          pFeatureselection.SelectFeatures pFilter, operator, False
        Else
          If (operator = esriSelectionResultNew) Then pFeatureselection.Clear
        End If
      End If
    Else
      If (FoundLayer(lstClass.List(j), pFeatureLayer)) Then
        Set pFeatureselection = pFeatureLayer
        If ((operator = esriSelectionResultNew) Or _
            (operator = esriSelectionResultAnd)) Then pFeatureselection.Clear
      End If
    End If
  Next j
  Debug.Print pFeatureLayer.name
  pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
  frmMDIMain.ActiveBar.Bands("StatusBar").Tools("StatusBarLabel").Caption = "选择实体数目: " & CStr(m_pMap.SelectionCount)
  RefreshSelectButtons
  
  Exit Sub
ErrorHandler:
  MsgBox "An unexpected error has occured with the Selection Dialog." & vbCr & vbCr & _
         "Details : " & Err.Description, vbExclamation + vbOKOnly, "Error"
End Sub

Private Sub QueryBySpace(operator As esriSelectionResultEnum)
  Dim pClassList As Collection
  Dim i As Long
  Dim j As Long
  Dim pElement As IElement
  Dim relOperator As esriSpatialRelEnum
  Dim pGeometry As IGeometry
  Dim pPoint As IPoint
  Dim pEnv As IEnvelope
  Dim pSelectEnv As ISelectionEnvironment
  Dim pActiveView As IActiveView
 ' Dim pMxApp As IMxApplication
  Dim prevSelMethod As esriSelectionResultEnum
  Dim shiftKeyDown As Boolean
  Dim prevAreaSelection As esriSpatialRelEnum
  Dim prevLineSelection As esriSpatialRelEnum
  Dim prevPointSelection As esriSpatialRelEnum
  Dim pColn As Collection
  Dim player As ILayer
  Dim pGeoLayer As IGeoFeatureLayer
  
  On Error GoTo ErrorHandler
  
  If (m_pSearchGeometry Is Nothing) Then Exit Sub
  
  'Set pMxApp = m_pApp

  Set pSelectEnv = New SelectionEnvironment
  prevAreaSelection = pSelectEnv.AreaSelectionMethod
  prevLineSelection = pSelectEnv.LinearSelectionMethod
  prevPointSelection = pSelectEnv.PointSelectionMethod
  If (optSpatialOp(0).Value = True) Then
    pSelectEnv.AreaSelectionMethod = esriSpatialRelContains
  ElseIf (optSpatialOp(1).Value = True) Then
    pSelectEnv.AreaSelectionMethod = esriSpatialRelCrosses
  ElseIf (optSpatialOp(2).Value = True) Then
   pSelectEnv.AreaSelectionMethod = esriSpatialRelIntersects
  ElseIf (optSpatialOp(3).Value = True) Then
    pSelectEnv.AreaSelectionMethod = esriSpatialRelOverlaps
  ElseIf (optSpatialOp(4).Value = True) Then
    pSelectEnv.AreaSelectionMethod = esriSpatialRelTouches
  ElseIf (optSpatialOp(5).Value = True) Then
    pSelectEnv.AreaSelectionMethod = esriSpatialRelWithin
  End If
  pSelectEnv.LinearSelectionMethod = pSelectEnv.AreaSelectionMethod
  pSelectEnv.PointSelectionMethod = pSelectEnv.AreaSelectionMethod
  ' now set the layers to be search through.  This is done by going through and setting all
  ' non searchable layers to false
  
  prevSelMethod = pSelectEnv.CombinationMethod
  pSelectEnv.CombinationMethod = operator

  Set pActiveView = m_pMap
  If (prevSelMethod <> esriSelectionResultAdd) Then pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
  
  
  Set pColn = New Collection
  For i = 0 To (m_pMap.LayerCount - 1)
    Set player = m_pMap.Layer(i)
    If (TypeOf player Is IGeoFeatureLayer) Then
      Set pGeoLayer = player
      pColn.Add pGeoLayer.Selectable, CStr(i)
      pGeoLayer.Selectable = False
      For j = 0 To lstClass.ListCount - 1
        If (lstClass.Selected(j)) Then
          If (lstClass.List(j) = pGeoLayer.name) Then
            pGeoLayer.Selectable = True
            j = lstClass.ListCount
          End If
        End If
      Next j
    End If
  Next i
  m_pMap.SelectByShape m_pSearchGeometry, pSelectEnv, False
  pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing

  ' reset the selection status of thje layers back
  For i = 0 To (m_pMap.LayerCount - 1)
    Set player = m_pMap.Layer(i)
    If (TypeOf player Is IGeoFeatureLayer) Then
      Set pGeoLayer = player
      pGeoLayer.Selectable = pColn.Item(CStr(i))
    End If
  Next i
  
  pSelectEnv.CombinationMethod = prevSelMethod
  pSelectEnv.AreaSelectionMethod = prevAreaSelection
  pSelectEnv.LinearSelectionMethod = prevLineSelection
  pSelectEnv.PointSelectionMethod = prevLineSelection
  RefreshSelectButtons

  Exit Sub
ErrorHandler:
  MsgBox "An unexpected error has occured with the Selection Dialog." & vbCr & vbCr & _
         "Details : " & Err.Description, vbExclamation + vbOKOnly, "Error"
End Sub

Private Sub RefreshMapDocument()

  Set m_pMap = Nothing
  Set m_pMapEvents = Nothing
  Set m_PLEvents = Nothing
  
  
  ' make sure there is a map to refresh
  If (frmMDIMap.MapControl.ActiveView.FocusMap Is Nothing) Then Exit Sub
  Set m_pMapEvents = frmMDIMap.MapControl.ActiveView.FocusMap
  Set m_pMap = frmMDIMap.MapControl.ActiveView.FocusMap
  
  RefreshList
End Sub
  
Private Sub RefreshList()
  Dim i As Long
  
  lstClass.Clear
  lstAttribute.Clear
  cboOperator.ListIndex = 0
  For i = 0 To m_pMap.LayerCount - 1
    If (TypeOf m_pMap.Layer(i) Is IGeoFeatureLayer) Then
      lstClass.AddItem m_pMap.Layer(i).name
    End If
  Next i
  
End Sub

Public Sub RefreshSelectButtons()
  Dim enable As Boolean
  
  If (m_pMap Is Nothing) Then
    enable = False
  Else
    enable = (m_pMap.SelectionCount > 0)
  End If
  
  If (enable) Then
    Selections
  Else
    NoSelections
  End If
  lblBuffer.Enabled = enable
  sldBuffer.Enabled = enable
  optUseMBRs.Enabled = enable
  cmdGeometryButton.Item(3).Enabled = enable
End Sub

Private Sub NoSelections()
  If (tbsOptions.SelectedItem.Index = 3) Then
    cmdApply.Enabled = (Not m_pSearchGeometry Is Nothing)
  Else
    cmdApply.Enabled = True
    cmdDismiss.Enabled = True
    cmdDiscard.Enabled = False
    cmdKeep.Enabled = False
  End If
End Sub

Private Sub Selections()
  If (tbsOptions.SelectedItem.Index = 3) Then
    cmdApply.Enabled = (Not m_pSearchGeometry Is Nothing)
    cmdDismiss.Enabled = (Not m_pSearchGeometry Is Nothing)
    cmdDiscard.Enabled = (Not m_pSearchGeometry Is Nothing)
    cmdKeep.Enabled = (Not m_pSearchGeometry Is Nothing)
  Else
    cmdApply.Enabled = True
    cmdDismiss.Enabled = True
    cmdDiscard.Enabled = True
    cmdKeep.Enabled = True
  End If
End Sub