frmquery.frm

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

   Begin MSComctlLib.TabStrip tbsOptions 
      Height          =   3810
      Left            =   120
      TabIndex        =   36
      Top             =   120
      Width           =   6120
      _ExtentX        =   10795
      _ExtentY        =   6720
      MultiRow        =   -1  'True
      Separators      =   -1  'True
      _Version        =   393216
      BeginProperty Tabs {1EFB6598-857C-11D1-B16A-00C0F0283628} 
         NumTabs         =   3
         BeginProperty Tab1 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "对象图层"
            Key             =   "Class"
            Object.ToolTipText     =   "Query Features By Class"
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab2 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "属性"
            Key             =   "Attribute"
            Object.ToolTipText     =   "Query Features By Attribute"
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab3 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "空间查找 "
            Key             =   "Spatial Constraint"
            Object.ToolTipText     =   "Quary Features By Spatial Constraint"
            ImageVarType    =   2
         EndProperty
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "frmQuery"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

' Constants used within the code
Private Const VK_CONTROL = &H11
Private Const VK_SHIFT = &H10
Private Const VK_ESCAPE = &H1B
Private Const PM_NOREMOVE = &H0
Private Const PM_REMOVE = &H1
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const VK_RETURN = &HD
Private Const WM_QUIT = &H12
Private Const WM_LBUTTONDOWN = &H201

' Win API functions used within this class
Private Declare Function GetKeyState% Lib "user32" (ByVal nKey%)
Private Declare Function PeekMessage Lib "user32" Alias _
                         "PeekMessageA" (lpMsg As MSG, ByVal hWnd As Long, _
                                         ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, _
                                         ByVal wRemoveMsg As Long) As Long
Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long


Private Type POINTAPI
  x As Long
  y As Long
End Type

Private Type MSG
  hWnd As Long
  message As Long
  wParam As Long
  lParam As Long
  time As Long
  pt As POINTAPI
End Type

Private WithEvents m_PLEvents As PageLayout             ' Events occuring in the page layout
Attribute m_PLEvents.VB_VarHelpID = -1
Private WithEvents m_pMapEvents As Map                  ' Connection Point on map IActiveViewEvents
Attribute m_pMapEvents.VB_VarHelpID = -1
                                                    ' because the Map object (m_pMapEvents) does not fire
                                                        ' the FocusMap changed event
Private m_pSearchPolygon As IPolygon   ' Used to represent the area graphically
Private m_pSearchGeometry As IGeometry ' Actual geometry used to search


'*** IDocumentEvents

Private Sub m_pDocumentEvents_ActiveViewChanged()
' Fired when switching bw dataview and pagelayout
' Or when switching dataframes in dataview
  RefreshMapDocument
End Sub

Private Sub m_pDocumentEvents_CloseDocument()
  'Set this to Nothing so ArcMap will properly close
  'Set m_pDocumentEvents = Nothing
End Sub

'*** PageLayout events

Private Sub m_PLEvents_FocusMapChanged()
' Fired when switching dataframes in pagelayout
  RefreshMapDocument
End Sub


'*** IMapEvents

Private Sub m_pMapEvents_AfterDraw(ByVal Display As esriDisplay.IDisplay, ByVal phase As esriCarto.esriViewDrawPhase)
  If (phase = esriViewForeground) Then DrawPolygonXOR Nothing, True
End Sub

Private Sub m_pMapEvents_ItemAdded(ByVal Item As Variant)
  RefreshList
End Sub

Private Sub m_pMapEvents_ItemDeleted(ByVal Item As Variant)
  RefreshList
End Sub

Private Sub m_pMapEvents_SelectionChanged()
  RefreshSelectButtons
End Sub

'*** FORM Class Events

Private Sub Form_Activate()
  ' make sure the map document is set before displaying the form
  ' Doing this adds the connection point to the map so we can get the
  ' event from the map.  These events keep things in step
  If (m_pMap Is Nothing) Then
    RefreshMapDocument
  Else
    RefreshList
  End If
  
  ' This ensures that the hide / show methods are in step with visibility of form
  frmQuery.SetFocus
End Sub

Private Sub Form_KeyDown(keyCode As Integer, Shift As Integer)
  Dim i As Integer
  'handle ctrl+tab to move to the next tab
  If Shift = vbCtrlMask And keyCode = vbKeyTab Then
    i = tbsOptions.SelectedItem.Index
    If i = tbsOptions.Tabs.count Then
      'last tab so we need to wrap to tab 1
      Set tbsOptions.SelectedItem = tbsOptions.Tabs(1)
    Else
      'increment the tab
      Set tbsOptions.SelectedItem = tbsOptions.Tabs(i + 1)
    End If
  End If
End Sub

Private Sub Form_Load()
  ' set search area button pictures
  cmdGeometryButton(0).Picture = imlBitmaps.ListImages(7).Picture
  cmdGeometryButton(1).Picture = imlBitmaps.ListImages(5).Picture
  cmdGeometryButton(2).Picture = imlBitmaps.ListImages(8).Picture
  cmdGeometryButton(3).Picture = imlBitmaps.ListImages(6).Picture
  cmdGeometryButton(4).Picture = imlBitmaps.ListImages(2).Picture
  cmdGeometryButton(5).Picture = imlBitmaps.ListImages(1).Picture
  cmdGeometryButton(6).Picture = imlBitmaps.ListImages(4).Picture
  cmdGeometryButton(7).Picture = imlBitmaps.ListImages(3).Picture
End Sub

Private Sub Form_Unload(Cancel As Integer)
  ' Form unloading so set the member variables to nothing
  Set m_pMapEvents = Nothing
End Sub

'*** Form Controls

Private Sub cmdApply_Click()
  Dim result As esriSelectionResultEnum
  
  ' Apply button pressed.     If control key is depressed then add this selections
  ' of this operation to the current selection set, other wise create a new one
  If (Not (GetKeyState(VK_CONTROL) < 0)) Then
    result = esriSelectionResultNew
  Else
    result = esriSelectionResultAdd
  End If
  
  Select Case tbsOptions.SelectedItem.Index
    Case 1
      QueryByClass result
    Case 2
      QueryByAttribute result
    Case 3
      QueryBySpace result
  End Select
End Sub

Private Sub cmdDiscard_Click()
  ' Discard button pressed.   Remove the any matches to this query from the current selection set
  Select Case tbsOptions.SelectedItem.Index
    Case 1
      QueryByClass esriSelectionResultSubtract
    Case 2
      QueryByAttribute esriSelectionResultSubtract
    Case 3
      QueryBySpace esriSelectionResultSubtract
  End Select
End Sub

Private Sub cmdDismiss_Click()
  ' Form dismissed, clear the search geometry from the screen and hide the form
  cmdGeometryButton_Click 1
  Unload Me
End Sub

Private Sub cmdKeep_Click()
  ' Keep key pressed.    Keep any matches with this query in the current selection set
  Select Case tbsOptions.SelectedItem.Index
    Case 1
      QueryByClass esriSelectionResultAnd
    Case 2
      QueryByAttribute esriSelectionResultAnd
    Case 3
      QueryBySpace esriSelectionResultAnd
  End Select
End Sub

Private Function BlockForPoint() As Boolean
  Dim MyMsg As MSG
  Dim RetVal As Long
  Dim count As Long
  
  ' Simply loop around until the mouse up, quit event or Escape key is
  ' recieved in the window.   All other events are passed along as normal
  Do
    RetVal = PeekMessage(MyMsg, frmMDIMain.hWnd, 0, 0, PM_REMOVE)
    If (MyMsg.wParam = VK_ESCAPE) Then
      BlockForPoint = True
      Exit Function '
    ElseIf (MyMsg.message = WM_LBUTTONDOWN) Then
      Exit Function
    End If
    TranslateMessage MyMsg
    DispatchMessage MyMsg
  Loop While (MyMsg.message <> WM_QUIT)
  BlockForPoint = True
End Function

Private Sub cmdGeometryButton_Click(Index As Integer)
  Dim i As Long
  Dim pCombEnv As IEnvelope
  Dim pFeatGeom As IGeometry
  Dim pSelected As IEnumFeature
  Dim pFeature As iFeature
  Dim pPointCollection As IPointCollection
  Dim pPolygon As IPolygon
  Dim pPoint As IPoint
  Dim pActiveView As IActiveView
  Dim pPolyTopo As ITopologicalOperator
  Dim pMinorPoly As IPolygon
  Dim pTopo As ITopologicalOperator
  Dim pRubberBand As IRubberBand
  Dim pRubberBandGeometry As IGeometry
  Dim pEnv As IEnvelope
  
  ' One of the icons that sets the search area has been pressed.  Select which one
  ' and then perform the action required.
  Set pActiveView = m_pMap
  Set pPolygon = New Polygon
  Set pPointCollection = pPolygon
  Select Case Index
    Case 0 ' Select feature
      frmQuery.Visible = False
      If (Not BlockForPoint()) Then
        Set pRubberBand = New RubberPoint
        Set pRubberBandGeometry = pRubberBand.TrackNew(pActiveView.ScreenDisplay, Nothing)
        If (Not pRubberBandGeometry Is Nothing) Then
          ' Using this geometry as the search criteria look for the nearest feature
          ' in the order of pts, lines then areas
          ' The search envelope is 16x16 pixels
          
          Set pEnv = pRubberBandGeometry.Envelope
          pEnv.Width = ConvertPixelsToRW(16)
          pEnv.Height = ConvertPixelsToRW(16)
          pEnv.CenterAt pRubberBandGeometry
          GetNearestObject pEnv, pFeature
        
          ' Make sure pFeature is valid and if it is grap the geometry from it
          If (pFeature Is Nothing) Then
            Beep
            MsgBox "No Feature Selected.   Spatial extent not updated.", vbInformation + vbOKOnly, "No Feature"
            frmQuery.Visible = True
            frmQuery.SetFocus
            Exit Sub
          End If
          Set pPolygon = New Polygon
          ' possible that we don't have a polygon so create one if required
          If (TypeOf pFeature.Shape Is IPolygon) Then
            Set pPolygon = pFeature.Shape
          Else
            Set pTopo = pFeature.Shape
            pTopo.Simplify
            If (TypeOf pFeature.Shape Is IPoint) Then
              Set pPolygon = pTopo.Buffer(ConvertPixelsToRW(10))
            Else
              Set pPolygon = pTopo.Buffer(ConvertPixelsToRW(2))
            End If
          End If
          DrawPolygonXOR Nothing
          DrawPolygonXOR pPolygon
          Set m_pSearchGeometry = pFeature.ShapeCopy
        End If
      End If
    Case 1  ' clear search
      DrawPolygonXOR Nothing
      Set m_pSearchGeometry = Nothing
    Case 2  ' Window extents
      Set pPointCollection = pPolygon
      pPointCollection.AddPoint pActiveView.Extent.LowerLeft
      pPointCollection.AddPoint pActiveView.Extent.LowerRight
      pPointCollection.AddPoint pActiveView.Extent.UpperRight
      pPointCollection.AddPoint pActiveView.Extent.UpperLeft
      DrawPolygonXOR Nothing
      DrawPolygonXOR pPolygon
      Set m_pSearchGeometry = pPolygon
    Case 3  ' Use selected features
      If (m_pMap.SelectionCount < 1) Then Exit Sub
      Set pSelected = m_pMap.FeatureSelection
      pSelected.Reset
      If (optUseMBRs.Value = vbUnchecked) Then
        Set pPolygon = New Polygon
        Set pTopo = pPolygon
        pTopo.Simplify
        Do
          Set pFeature = pSelected.Next
          If (Not pFeature Is Nothing) Then
            ' possible that we don't have a polygon so create one if required
            If (TypeOf pFeature.Shape Is IPolygon) Then
              Set pMinorPoly = pFeature.Shape
            Else
              Set pTopo = pFeature.ShapeCopy
              pTopo.Simplify
              If (TypeOf pFeature.Shape Is IPoint) Then
                Set pMinorPoly = pTopo.Buffer(ConvertPixelsToRW(2))
              Else
                Set pMinorPoly = pTopo.Buffer(ConvertPixelsToRW(2))
              End If
            End If
            Set pPolyTopo = pMinorPoly
            pPolyTopo.Simplify
            Set pPolygon = pPolyTopo.Union(pPolygon)
          End If
        Loop While (Not pFeature Is Nothing)
      Else
        Set pFeature = pSelected.Next
        Set pFeatGeom = pFeature.ShapeCopy
        Set pCombEnv = pFeatGeom.Envelope
        Do
          Set pFeature = pSelected.Next
          If (Not pFeature Is Nothing) Then
            Set pFeatGeom = pFeature.ShapeCopy
            pCombEnv.Union pFeatGeom.Envelope
          End If
        Loop While (Not pFeature Is Nothing)
        
        Set pPolygon = New Polygon
        Set pPointCollection = pPolygon
        pPointCollection.AddPoint pCombEnv.LowerLeft
        pPointCollection.AddPoint pCombEnv.LowerRight
        pPointCollection.AddPoint pCombEnv.UpperRight
        pPointCollection.AddPoint pCombEnv.UpperLeft
      End If
      Set m_pSearchGeometry = pPolygon
      DrawPolygonXOR Nothing
      DrawPolygonXOR pPolygon
    Case 4 ' Line
      frmQuery.Visible = False
      If (Not BlockForPoint()) Then
        Set pRubberBand = New RubberLine
        Set pRubberBandGeometry = New Polyline
        Set pRubberBandGeometry = pRubberBand.TrackNew(pActiveView.ScreenDisplay, Nothing)
        If (Not pRubberBandGeometry Is Nothing) Then
          Set pPointCollection = pRubberBandGeometry
      
          ' create a new object if the ruber band geometry has more then one point
          If (pPointCollection.PointCount > 1) Then
            Set pTopo = pRubberBandGeometry
            pTopo.Simplify
            Set pPolygon = pTopo.Buffer(ConvertPixelsToRW(2))
            DrawPolygonXOR Nothing
            DrawPolygonXOR pPolygon
            Set m_pSearchGeometry = Nothing
            Set m_pSearchGeometry = pRubberBandGeometry
          Else
            GiveWarning "Digitising Error", "The search line must have at least two points"
          End If