frmquery.frm

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

          Set pRubberBand = Nothing
          Set pRubberBandGeometry = Nothing
        End If
      End If
    Case 5  ' Area
      frmQuery.Visible = False
      If (Not BlockForPoint()) Then
        Set pRubberBand = New RubberPolygon
        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 > 2) Then
            Set pPolygon = pRubberBandGeometry
            DrawPolygonXOR Nothing
            DrawPolygonXOR pPolygon
            Set m_pSearchGeometry = pPolygon
          Else
            GiveWarning "Digitising Error", "The search polygon must have at least three points"
          End If
          Set pRubberBand = Nothing
          Set pRubberBandGeometry = Nothing
        End If
      End If
    Case 6  ' Region
      frmQuery.Visible = False
      If (Not BlockForPoint()) Then
        Set pRubberBand = New RubberEnvelope
        Set pRubberBandGeometry = pRubberBand.TrackNew(pActiveView.ScreenDisplay, Nothing)
        If (Not pRubberBandGeometry Is Nothing) Then
          Set pPolygon = New Polygon
          Set pPointCollection = pPolygon
          pPointCollection.AddPoint pRubberBandGeometry.Envelope.LowerLeft
          pPointCollection.AddPoint pRubberBandGeometry.Envelope.LowerRight
          pPointCollection.AddPoint pRubberBandGeometry.Envelope.UpperRight
          pPointCollection.AddPoint pRubberBandGeometry.Envelope.UpperLeft
          DrawPolygonXOR Nothing
          DrawPolygonXOR pPolygon
          Set pRubberBand = Nothing
          Set pRubberBandGeometry = Nothing
          Set m_pSearchGeometry = pPolygon
        End If
      End If
    Case 7  ' Point
      frmQuery.Visible = False
      If (Not BlockForPoint()) Then
        Set pRubberBand = New RubberPoint
        Set pRubberBandGeometry = pRubberBand.TrackNew(pActiveView.ScreenDisplay, Nothing)
        If (Not pRubberBandGeometry Is Nothing) Then
          Set pTopo = pRubberBandGeometry
          pTopo.Simplify
          Set pPolygon = pTopo.Buffer(ConvertPixelsToRW(10))
          DrawPolygonXOR Nothing
          DrawPolygonXOR pPolygon
          Set m_pSearchGeometry = pRubberBandGeometry
        End If
      End If
  End Select
  cmdApply.Enabled = (Not m_pSearchGeometry Is Nothing)
  
  frmQuery.Visible = True
  frmQuery.SetFocus
  ' Refresh the select buttons
  RefreshSelectButtons
End Sub

Private Sub lstClass_Click()
  Dim i As Long
  Dim pFeatureClass As IFeatureClass
  Dim j As Long
  Dim player As IGeoFeatureLayer
  Dim pFields As IFields
  Dim pAttList As Collection
  Dim pTryList As Collection
  Dim init As Boolean
  Dim okayToAdd As Boolean
  On Error GoTo ErrorHandler
  
  Set pTryList = New Collection
  Set pAttList = New Collection
  
  init = False
  ' Class list is selected so the attribute list must be updated
  lstAttribute.Clear
  For i = 0 To m_pMap.LayerCount - 1
    If (lstClass.Selected(i)) Then
      ' get the name of the class and look for that in the layers list
      For j = 0 To m_pMap.LayerCount - 1
        Set player = m_pMap.Layer(j)
        If (player.name = lstClass.List(i)) Then
          Set pFeatureClass = player.FeatureClass
          j = m_pMap.LayerCount
        End If
      Next j
      Set pAttList = Nothing
      Set pAttList = New Collection
      Set pFields = pFeatureClass.Fields
      For j = 0 To pFields.FieldCount - 1
        If (Not init) Then
          pAttList.Add pFields.Field(j).AliasName, pFields.Field(j).AliasName
        Else
          okayToAdd = False
          pTryList.Add pFields.Field(j).AliasName, pFields.Field(j).AliasName
          If (okayToAdd) Then
            pAttList.Add pFields.Field(j).AliasName
          End If
        End If
      Next j
      init = True
      Set pTryList = Nothing
      Set pTryList = New Collection
      For j = 1 To pAttList.count
        pTryList.Add pAttList.Item(j), pAttList.Item(j)
      Next j
    End If
  Next i

  For i = 1 To pTryList.count
    lstAttribute.AddItem pTryList.Item(i)
  Next i
  Exit Sub
ErrorHandler:
  okayToAdd = True
  Resume Next
End Sub

Private Sub optSpatialOp_Click(Index As Integer)
  ' Spatial operator updated so set the tooltip text appropriately
  Select Case Index
    Case 0
      fraSpatialOperator.ToolTipText = "Spatial extent contains class"
    Case 1
      fraSpatialOperator.ToolTipText = "Spatial extent crosses class"
    Case 2
      fraSpatialOperator.ToolTipText = "Spatial extent intersects class"
    Case 3
      fraSpatialOperator.ToolTipText = "Spatial extent overlaps class"
    Case 4
      fraSpatialOperator.ToolTipText = "Spatial extent touches class"
    Case 5
      fraSpatialOperator.ToolTipText = "Spatial extent within class"
  End Select
End Sub

Private Sub optUseMBRs_Click()
  ' Option for using MBRs or feature geometry has been pressed
  ' Simple refresh the selected objects search geometry by calling the
  ' appropriate button event handler
  If (Not m_pSearchPolygon Is Nothing) Then cmdGeometryButton_Click 3
End Sub

Private Sub sldBuffer_Scroll()
  Dim bufferRadius As Double
  Dim pSelected As IEnumFeature
  Dim pFeature As iFeature
  Dim pTopo As ITopologicalOperator
  Dim pPolygon As IPolygon
  Dim pPolyTopo As ITopologicalOperator
  Dim pMinorPoly As IPolygon
  Dim pGeom As IGeometry
  Dim i As Long
  Dim generalOffset As Double
  Dim pPolyCurve As IPolycurve
  Dim noGeneralise As Boolean
  Dim result As VbMsgBoxResult
  
  On Error GoTo ErrorHandler
  
  result = vbNo
  bufferRadius = sldBuffer.Value
  bufferRadius = ConvertPixelsToRW(bufferRadius)
  
  ' calculate the simplification parameter based on the buffer size
  generalOffset = bufferRadius / 20#
  Set pPolygon = New Polygon
  Set pTopo = pPolygon
  pTopo.Simplify
  sldBuffer.ToolTipText = CStr(Round(bufferRadius, 4))
  ' got the buffer so grab the object and buffer it
  If (m_pMap.SelectionCount < 1) Then Exit Sub
  Set pSelected = m_pMap.FeatureSelection
  pSelected.Reset
  Do
    Set pFeature = pSelected.Next
    If (Not pFeature Is Nothing) Then
      Set pGeom = pFeature.ShapeCopy
      If (TypeOf pGeom Is IPoint) Then
        Set pTopo = pGeom
        noGeneralise = True
      Else
        noGeneralise = False
        Set pPolyCurve = pGeom
        pPolyCurve.Generalize (generalOffset)
        Set pTopo = pPolyCurve
      End If
      pTopo.Simplify
      Set pMinorPoly = pTopo.Buffer(bufferRadius)
      If (Not noGeneralise) Then pMinorPoly.Generalize (generalOffset)
      Set pPolyTopo = pMinorPoly
      pPolyTopo.Simplify
      Set pPolygon = pPolyTopo.Union(pPolygon)
    End If
  Loop While (Not pFeature Is Nothing)
  DrawPolygonXOR Nothing
  DrawPolygonXOR pPolygon
  Set m_pSearchGeometry = pPolygon
  
  ' Refresh the select buttons
  RefreshSelectButtons
  
  Exit Sub
ErrorHandler:
  MsgBox "Error in Geometry Sub System" & vbCrLf & vbCrLf & _
         "Error Details : " & Err.Description, vbExclamation + vbOKOnly, "Buffer Error"
End Sub

Private Sub tbsOptions_Click()
  Dim i As Integer
  'show and enable the selected tab's controls
  'and hide and disable all others
  For i = 0 To tbsOptions.Tabs.count - 1
    If i = tbsOptions.SelectedItem.Index - 1 Then
      picFrame(i).Visible = True
      picFrame(i).Enabled = True
    Else
      picFrame(i).Visible = False
      picFrame(i).Enabled = False
    End If
  Next
  RefreshSelectButtons
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub Public_StartQuery()
  Set m_pMapEvents = frmMDIMap.MapControl.ActiveView.FocusMap
End Sub


'*** Miscellaneous Functions and Sub Routines

Private Function ConvertPixelsToRW(pixelUnits As Double) As Double
  Dim realWorldDisplayExtent As Double
  Dim pixelExtent As Long
  Dim sizeOfOnePixel As Double
  Dim pDT As IDisplayTransformation
  Dim deviceRect As tagRECT
  Dim pEnv As IEnvelope
  Dim pActiveView As IActiveView
  
  ' Get the width of the display extents in Pixels
  ' and get the extent of the displayed data
  ' work out the size of one pixel and then return
  ' the pixels units passed in mulitplied by that value
  Set pActiveView = m_pMap
  Set pDT = pActiveView.ScreenDisplay.DisplayTransformation
  deviceRect = pDT.DeviceFrame
  pixelExtent = deviceRect.Right - deviceRect.Left
  Set pEnv = pDT.VisibleBounds
  
  realWorldDisplayExtent = pEnv.Width
  sizeOfOnePixel = realWorldDisplayExtent / pixelExtent
  ConvertPixelsToRW = pixelUnits * sizeOfOnePixel
End Function

Public Sub DrawPolygonXOR(pPolygon As IPolygon, Optional refresh As Boolean)
  Dim pFillSymbol As IFillSymbol
  Dim pLineSymbol As ILineSymbol
  Dim pSymbol As ISymbol
  Dim pRgbColor As IRgbColor
  Dim pActiveView As IActiveView
  Dim pLSymbol As ISymbol
  
  ' This function draws a polygon on the screen using a XOR pen
  ' it is used by the buffer routine to quickly draw  and undraw a
  ' polygon on the screen without the need to redraw any other features
  
  ' construct the symbol
  Set pFillSymbol = New SimpleFillSymbol
  Set pSymbol = pFillSymbol

  ' set the drawing mode so that two draws undraw the symbol
  pSymbol.ROP2 = esriROPXOrPen
  
  Set pRgbColor = New RgbColor
  With pRgbColor
    .UseWindowsDithering = False
    .Red = 45
    .Green = 45
    .Blue = 45
  End With
  pFillSymbol.color = pRgbColor
  
  Set pLineSymbol = pFillSymbol.Outline
  Set pLSymbol = pLineSymbol
  pLSymbol.ROP2 = esriROPXOrPen
  With pRgbColor
    .UseWindowsDithering = False
    .Red = 145
    .Green = 145
    .Blue = 145
  End With
  pLineSymbol.color = pRgbColor
  pLineSymbol.Width = 0.1
  pFillSymbol.Outline = pLineSymbol
  
  ' Set the symbol into the display
  Set pActiveView = m_pMap
  pActiveView.ScreenDisplay.StartDrawing 0, esriNoScreenCache
  pActiveView.ScreenDisplay.SetSymbol pSymbol
  
  ' if func called to draw aswell as undraw then plot the polygon
  If (pPolygon Is Nothing) Then
    If (Not m_pSearchPolygon Is Nothing) Then pActiveView.ScreenDisplay.DrawPolygon m_pSearchPolygon
    If (Not refresh) Then Set m_pSearchPolygon = Nothing
  Else
    Set m_pSearchPolygon = Nothing
    pActiveView.ScreenDisplay.DrawPolygon pPolygon
    Set m_pSearchPolygon = pPolygon
  End If
  pActiveView.ScreenDisplay.FinishDrawing
End Sub

Private Sub GetClosestFeatureInCollection(searchCollection As Collection, _
                                          pPoint As IPoint, _
                                          pFeature As iFeature, _
                                          Optional removeIndex As Long)
  Dim i As Long
  Dim testDistance As Double
  Dim pProximity As IProximityOperator
  Dim pGeom As IGeometry
  Dim pTestFeature As iFeature
  Dim tempDist As Double
  Dim searchDist As Double
  Dim pPointFeature As iFeature
  Dim pLineFeature As iFeature
  Dim pAreaFeature As iFeature
  Dim pointTestDistance As Double
  Dim lineTestDistance As Double
  Dim areaTestDistance As Double
  Dim pointRemoveIndex As Long
  Dim lineRemoveIndex As Long
  Dim areaRemoveIndex As Long
  
  On Error GoTo ErrorHandler
  
  ' Search through a collection of features and get the closest one
  ' in the order of points lines then areas
  
  ' First check that we have an object selected
  If (searchCollection.count < 1) Then
    Exit Sub
  End If
  
  ' get the search tolerance in RW units
  searchDist = 16
  searchDist = ConvertPixelsToRW(searchDist)

  ' initialise some variable before entering the loop
  pointTestDistance = -1
  lineTestDistance = -1
  areaTestDistance = -1
  testDistance = -1
  
 ' find the closest feature to the cursor position
  Set pProximity = pPoint
  For i = 1 To searchCollection.count
    Set pTestFeature = searchCollection.Item(i)
    Set pGeom = pTestFeature.Shape
    tempDist = pProximity.ReturnDistance(pGeom)
    
    If (tempDist < searchDist) Then
      Select Case pGeom.GeometryType
        Case esriGeometryPoint
          If (pointTestDistance < 0) Then pointTestDistance = tempDist + 1
          If (tempDist < pointTestDistance) Then
            pointTestDistance = tempDist
            Set pPointFeature = pTestFeature
            pointRemoveIndex = i
          End If
        Case esriGeometryPolyline
          If (lineTestDistance < 0) Then lineTestDistance = tempDist + 1
          If (tempDist < lineTestDistance) Then
            lineTestDistance = tempDist
            Set pLineFeature = pTestFeature
            lineRemoveIndex = i
          End If
        Case esriGeometryPolygon
          If (areaTestDistance < 0) Then areaTestDistance = tempDist + 1
          If (tempDist < areaTestDistance) Then
            areaTestDistance = tempDist
            Set pAreaFeature = pTestFeature
            areaRemoveIndex = i
          End If
      End Select
    Else
      'initialize the test distance variable
      If (testDistance < 0) Then testDistance = tempDist + 1
      If (tempDist < testDistance) Then
        testDistance = tempDist
        Set pFeature = pTestFeature
        removeIndex = i
      End If
    End If
  Next i