find.frm

这个是grs源程序,mo在图象显示上很好,所以大家一定要下载

  
  Call rebuildListView

End Sub


Private Sub FindFeatures()
  'This procedure executes the Find command for the Find features form.
  Dim Exp As String, searchExp As String
  Dim layerCnt As Integer, layerCount As Integer
  layerCnt = frmMain.mapDisp.Layers.count
  ReDim layerName(layerCnt)
  ReDim Recs2(layerCnt)
  Dim aValue As String, aName As String
  Dim layer_Name As String, featCount As Integer
  Dim i As Integer, curCount As Integer
  Dim recs As MapObjects2.Recordset
  Dim Test As Boolean
  Dim aField As Object


  frmMain.mapDisp.TrackingLayer.ClearEvents
  Screen.MousePointer = vbHourglass
  featCount = -1: layerCount = -1
  searchExp = " like '%" + frmFind.cboSearchList + "%'"
  frmFind.grdFeatList.FixedRows = 0: frmFind.grdFeatList.Rows = 1
  
'For each field in each layer, look for the search string.
  
  For i = 0 To frmMain.mapDisp.Layers.count - 1
    If LayerStatus(i) = 1 Then
      layer_Name = frmMain.mapDisp.Layers(i).Name
      'Determine query expression (exp) and first string (aname).
      Exp = ""
      aName = ""
      For Each aField In frmMain.mapDisp.Layers(i).Records.Fields
        If aField.Type = moString Then
          If Exp = "" Then
            Exp = aField.Name + searchExp
          Else
            Exp = Exp + " or " + aField.Name + " like '%" + frmFind.cboSearchList + "%'"
          End If
          If aName = "" Then
            aName = aField.Name
          End If
        End If
      Next aField
      'Execute the query.
      If Exp = "" Then
        Set recs = Nothing
      Else
        Set recs = frmMain.mapDisp.Layers(i).SearchExpression(Exp)
      End If
      'Loop through selected features and store pointers.
      layerCount = layerCount + 1
      layerName(layerCount) = layer_Name
      Set Recs2(layerCount) = recs
      curCount = -1
      If Not recs Is Nothing Then
        While Not recs.EOF
          curCount = curCount + 1
          For Each aField In recs.Fields
            If aField.Type = moString Then
              aValue = recs(aField.Name)
              Dim theString As String
              theString = "*" + frmFind.cboSearchList + "*"
              If aValue Like theString Then
                featCount = featCount + 1
                If featCount = 0 Then
                  frmFind.grdFeatList.Row = 0: frmFind.grdFeatList.Col = 0
                  frmFind.grdFeatList.text = "Layer"
                  frmFind.grdFeatList.Col = 1: frmFind.grdFeatList.text = "Field"
                  frmFind.grdFeatList.Col = 2: frmFind.grdFeatList.text = "Value"
                End If
                ReDim Preserve layerNum(2, featCount)
                layerNum(1, featCount) = layerCount: layerNum(2, featCount) = curCount
                frmFind.grdFeatList.AddItem layer_Name & Chr(9) & aField.Name & Chr(9) & aValue
              End If
            End If
          Next aField
          recs.MoveNext
        Wend
      End If
    End If
  Next i
  
  If featCount >= 0 Then
    frmFind.grdFeatList.FixedRows = 1
  End If
  frmFind.lblNumFeats.Caption = str(featCount + 1) + " matches found"
  Test = True
  For i = 0 To frmFind.cboSearchList.ListCount
    If frmFind.cboSearchList.List(i) = frmFind.cboSearchList Then
      Test = False
    End If
  Next i
  If Test Then
    frmFind.cboSearchList.AddItem frmFind.cboSearchList, 0
  End If

  Screen.MousePointer = 0
End Sub

Private Sub cboSearchList_Change()
  Call check_cmdFindButton
End Sub

Private Sub cboSearchList_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then
    If frmFind.cmdFindButton.Enabled Then
      Call FindFeatures
    End If
  End If
End Sub


Private Sub Form_Terminate()
  frmMain.mapDisp.TrackingLayer.ClearEvents
End Sub

Private Sub grdFeatList_SelChange()

'Allow the user to interact with the selected features
'displayed in the Grid.  Have the user's selections
'trigger other actions like Highlight, InsertPin, Pan, and ZoomTo.

  frmFind.grdFeatList.SelStartCol = 0
  frmFind.grdFeatList.SelEndCol = 2
  If frmFind.grdFeatList.SelEndRow > frmFind.grdFeatList.SelStartRow Then
    frmFind.grdFeatList.SelEndRow = frmFind.grdFeatList.SelStartRow
  End If
  If frmFind.grdFeatList.SelStartRow > 0 Then
    frmFind.cmdHighlight.Enabled = True
    frmFind.cmdInsertPin.Enabled = True
    frmFind.cmdPanto.Enabled = True
    frmFind.cmdZoomto.Enabled = True
  Else
    frmFind.cmdHighlight.Enabled = False
    frmFind.cmdPanto.Enabled = False
    frmFind.cmdZoomto.Enabled = False
    frmFind.cmdInsertPin.Enabled = False
  End If
  
End Sub


Private Sub cmdFindButton_Click()
  Call FindFeatures
End Sub

Private Sub Form_Load()

'
' Set initial values.
'
  frmFind.grdFeatList.ColWidth(0) = 1300
  frmFind.grdFeatList.ColWidth(1) = 1300
  frmFind.grdFeatList.ColWidth(2) = 2200
  frmFind.grdFeatList.Rows = 1
  frmFind.grdFeatList.Cols = 3
  frmFind.cboSearchList.Clear
  
  'Set properties for the Map Contents list view.
  lvwLayerList.View = lvwReport
  ReDim LayerStatus(frmMain.mapDisp.Layers.count)
  Dim i As Integer
  For i = 0 To frmMain.mapDisp.Layers.count - 1
    If frmMain.mapDisp.Layers(i).LayerType = moImageLayer Then
      LayerStatus(i) = 0
    Else
      LayerStatus(i) = 1
    End If
  Next i

  Call rebuildListView
  
'
' Initialize the Trackinglayer for adding pins.
'
  Dim fnt As New StdFont
  fnt.Name = "Wingdings"
  fnt.Bold = False
  frmMain.mapDisp.TrackingLayer.SymbolCount = 1
  
  frmMain.mapDisp.TrackingLayer.Symbol(0).color = moBlue
  frmMain.mapDisp.TrackingLayer.Symbol(0).style = moTrueTypeMarker
  frmMain.mapDisp.TrackingLayer.Symbol(0).Font = fnt
  frmMain.mapDisp.TrackingLayer.Symbol(0).Size = 16
  frmMain.mapDisp.TrackingLayer.Symbol(0).CharacterIndex = 88
  frmMain.mapDisp.TrackingLayer.ClearEvents
  
End Sub

Private Sub Find_Actions(f_Action As String)

  Dim curRec As MapObjects2.Recordset
  Dim Rect As Rectangle, Rect2 As Rectangle
  Dim curIndex As Integer, aIndex As Integer
  Dim aRec As Integer, i As Integer
  Dim aName As String
  Dim shapeX As Double, shapeY As Double
  Dim deltax As Double, deltay As Double
  Dim theShape As Object, pinPoint As MapObjects2.Point

'
' Determine selected item from list.
'
  curIndex = frmFind.grdFeatList.SelStartRow - 1
  If IsNull(curIndex) Or curIndex < -1 Then
    Exit Sub
  End If
  aIndex = layerNum(1, curIndex)
  aRec = layerNum(2, curIndex)
  aName = layerName(aIndex)
  
'
' Set curRec variable to the correct record.
'
  Set curRec = Recs2(aIndex)
  curRec.MoveFirst
  
  If aRec > 0 Then
    For i = 1 To aRec
      curRec.MoveNext
    Next i
  End If
  
'
' Perform unique actions based on selected button.
'
  Select Case f_Action
  Case "cmdHighlight"
    frmMain.mapDisp.FlashShape curRec("shape").Value, 3
  Case "insert_pin"
    Set pinPoint = Nothing
    Select Case curRec("shape").Type
    Case moPoint
      Set pinPoint = curRec("shape").Value
    Case moLine
      MsgBox "Cannot insert a pin for a line feature"
    Case moPolygon
      Set pinPoint = curRec("shape").Value.Centroid
    End Select
    
    If Not pinPoint Is Nothing Then
      frmMain.mapDisp.TrackingLayer.AddEvent pinPoint, 0
    End If
  Case "cmdPanto"
    Set Rect2 = frmMain.mapDisp.Extent
    Set theShape = curRec("shape").Value
    If curRec("shape").Type = moPoint Then
      shapeX = curRec("shape").Value.x
      shapeY = curRec("shape").Value.y
    Else
      Set Rect = curRec("shape").Value.Extent
      shapeX = Rect.Center.x
      shapeY = Rect.Center.y
    End If
    deltax = shapeX - Rect2.Center.x
    deltay = shapeY - Rect2.Center.y
    Rect2.Offset deltax, deltay
    frmMain.mapDisp.Extent = Rect2
    frmMain.mapDisp.Refresh
    frmMain.mapDisp.FlashShape theShape, 3
  Case "cmdZoomto"
    Set theShape = curRec("shape").Value
    If curRec("shape").Type = moPoint Then
      Set Rect2 = frmMain.mapDisp.Extent
      shapeX = curRec("shape").Value.x
      shapeY = curRec("shape").Value.y
      deltax = shapeX - Rect2.Center.x
      deltay = shapeY - Rect2.Center.y
      Rect2.Offset deltax, deltay
      Rect2.ScaleRectangle 0.1
      frmMain.mapDisp.Extent = Rect2
    Else
      Set Rect = curRec("shape").Value.Extent
      Rect.ScaleRectangle 1.1
      frmMain.mapDisp.Extent = Rect
    End If
    frmMain.mapDisp.Refresh
    frmMain.mapDisp.FlashShape theShape, 3
  End Select

End Sub

Private Sub lvwLayerList_ItemClick(ByVal Item As ListItem)
'  If mouseX < 250 Then toggleCheckbox
  Call toggleCheckbox
  Call check_cmdFindButton
End Sub

'
'Trigger one of the four actions when the user selects a
'Grid item and hits one of the buttons.
'
Private Sub cmdHighlight_Click()
  Call Find_Actions("cmdHighlight")
End Sub

Private Sub cmdInsertPin_Click()
  Call Find_Actions("insert_pin")
End Sub

Private Sub cmdPanto_Click()
  Call Find_Actions("cmdPanto")
End Sub

Private Sub cmdZoomto_Click()
  Call Find_Actions("cmdZoomto")
End Sub