searchmain.frm

GIS地理信息系统开发。大名鼎鼎的MAPX＋VisualBasic6.0软件开发

         Strikethrough   =   0   'False
      EndProperty
      Map.Layers.Layer9.LabelProperties.Style.LineStyle=   1
      Map.Layers.Layer9.LabelProperties.Style.LineWidth=   1
      Map.NumericCoordSys.ProjectionInfo=   "searchMain.frx":0000
      Map.DisplayCoordSys.ProjectionInfo=   "searchMain.frx":0130
      Map.Zoom        =   3500
      Map.CenterX     =   -95.6166331857634
      Map.CenterY     =   38.2558614503343
      FeatureEditMode =   1
   End
   Begin VB.ComboBox searchFeatureLayerCombo 
      Height          =   315
      Left            =   9360
      TabIndex        =   4
      Text            =   " "
      Top             =   1320
      Width           =   2535
   End
   Begin VB.ComboBox searchLayerListCombo 
      Height          =   315
      Left            =   9360
      TabIndex        =   2
      Top             =   480
      Width           =   2535
   End
   Begin VB.ListBox searchResultsList 
      Height          =   3765
      ItemData        =   "searchMain.frx":0260
      Left            =   9240
      List            =   "searchMain.frx":0262
      TabIndex        =   0
      Top             =   2400
      Width           =   3135
   End
   Begin VB.Label searchFeatureLayerLabel 
      Caption         =   "Feature Search Layer"
      Height          =   375
      Left            =   9360
      TabIndex        =   5
      Top             =   960
      Width           =   1815
   End
   Begin VB.Label searchlayerListLabel 
      AutoSize        =   -1  'True
      Caption         =   "Search Layer"
      Height          =   195
      Left            =   9360
      TabIndex        =   3
      Top             =   120
      Width           =   945
   End
   Begin VB.Label searchResultsLabel 
      AutoSize        =   -1  'True
      Caption         =   "SearchResults"
      Height          =   195
      Left            =   9240
      TabIndex        =   1
      Top             =   2040
      Width           =   1035
   End
   Begin VB.Menu File 
      Caption         =   "File"
      Begin VB.Menu layerControlMenuItem 
         Caption         =   "Layer Control"
      End
      Begin VB.Menu exitMenuItem 
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu toolsMenuItem 
      Caption         =   "Tools"
      Begin VB.Menu zoomInToolMenuItem 
         Caption         =   "ZoomIn Tool"
      End
      Begin VB.Menu zoomOutToolMenuItem 
         Caption         =   "ZoomOut Tool"
      End
      Begin VB.Menu panToolMenuItem 
         Caption         =   "Pan Tool"
      End
   End
   Begin VB.Menu searchToolsMenuItem 
      Caption         =   "Search Tools"
      Begin VB.Menu searchDistanceMenuItem 
         Caption         =   "Search Within Distance"
      End
      Begin VB.Menu searchRectangleMenuItem 
         Caption         =   "Search Within Rectangle"
      End
      Begin VB.Menu searchFeatureMenuItem 
         Caption         =   "Search Within Feature"
      End
      Begin VB.Menu searchPointMenuItem 
         Caption         =   "Search At Point"
      End
      Begin VB.Menu add2selectionMenuItem 
         Caption         =   "Add Search To Selection"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' This sample application and corresponding sample code is provided
' for example purposes only.  It has not undergone rigorous testing
' and as such should not be shipped as part of a final application
' without extensive testing on the part of the organization releasing
' the end-user product.

Const SEARCH_DISTANCE_TOOL As Integer = 1
Const SEARCH_RECTANGLE_TOOL As Integer = 2
Const SEARCH_FEATURE_TOOL As Integer = 3
Const SEARCH_POINT_TOOL As Integer = 4
Public searchLayer As Object

Private Sub add2selectionMenuItem_Click()
    ' Toggle the Menu item checked property
    If add2selectionMenuItem.Checked = True Then
        add2selectionMenuItem.Checked = False
    Else
        add2selectionMenuItem.Checked = True
    End If
    Dim lyr As MapXLib.Layer
    'clear all layers selections after menu item is clicked
    For Each lyr In Map1.Layers
        lyr.Selection.ClearSelection
    Next
    Set lyr = Nothing
End Sub

Private Sub exitMenuItem_Click()
    ' Exit program
    End
End Sub

Private Sub Form_Load()
    ' Set up custom search tools
    Map1.CreateCustomTool SEARCH_DISTANCE_TOOL, miToolTypeCircle, miRadiusSelectCursor
    Map1.CreateCustomTool SEARCH_RECTANGLE_TOOL, miToolTypeMarquee, miRectSelectCursor
    Map1.CreateCustomTool SEARCH_FEATURE_TOOL, miToolTypePoint, miSelectCursor
    Map1.CreateCustomTool SEARCH_POINT_TOOL, miToolTypePoint, miCenterCursor
    ' update forms controls
    Call updateControls
End Sub

Private Sub layerControlMenuItem_Click()
    ' Display Layer Control MapX Stock Dialog
    Map1.Layers.LayersDlg
    ' update forms controls
    Call updateControls
End Sub
Private Sub Map1_ToolUsed(ByVal ToolNum As Integer, ByVal X1 As Double, ByVal Y1 As Double, ByVal X2 As Double, ByVal Y2 As Double, ByVal Distance As Double, ByVal Shift As Boolean, ByVal Ctrl As Boolean, EnableDefault As Boolean)
    Dim curFeatures As MapXLib.Features
    Dim obj As Object
    Dim pt As New MapXLib.Point
    On Error goto ErrHand
    
    If ToolNum <> SEARCH_POINT_TOOL Then
        'clear search list
        searchResultsList.Clear
        'Set search type
        Dim searchType As Integer
        If Shift And Not Ctrl Then
            searchType = miSearchTypePartiallyWithin
        ElseIf Ctrl And Not Shift Then
                searchType = miSearchTypeEntirelyWithin
            Else
                searchType = miSearchTypeCentroidWithin
        End If
    End If
    
    Select Case ToolNum
        Case SEARCH_DISTANCE_TOOL
            Dim dist As Double
            'Get distance to perform search
            dist = Map1.Distance(X1, Y1, X2, Y2)
            ' Set the point to start search
            pt.Set X1, Y1
            ' perform search
            Set curFeatures = searchLayer.SearchWithinDistance(pt, dist, miUnitMile, searchType)
            ' Add results of search to results list box control
            For Each obj In curFeatures
                searchResultsList.AddItem obj.Name & "  id: " & obj.FeatureID
            Next
            ' If menu item to add results to selection is true, the replace
            ' the selection for that layer with search results
            If add2selectionMenuItem.Checked = True Then
                searchLayer.Selection.Replace curFeatures
            End If
            
            ' Clear object Variables
            Set pt = Nothing
            Set curFeatures = Nothing
            Set obj = Nothing
        Case SEARCH_RECTANGLE_TOOL
            Dim rc As New MapXLib.Rectangle
            ' Set rectangle to be used in search
            rc.Set X1, Y1, X2, Y2
            ' Perform search
            Set curFeatures = searchLayer.SearchWithinRectangle(rc, searchType)
            ' Add results of search to results list box control
            For Each obj In curFeatures
                searchResultsList.AddItem obj.Name & "  id: " & obj.FeatureID
            Next
            ' If menu item to add results to selection is true, the replace
            ' the selection for that layer with search results
            If add2selectionMenuItem.Checked = True Then
                searchLayer.Selection.Replace curFeatures
            End If
            
            ' Clear object Variables
            Set pt = Nothing
            Set curFeatures = Nothing
            Set obj = Nothing
            Set rc = Nothing
        Case SEARCH_FEATURE_TOOL
            Dim featureLyr As MapXLib.Layer
            ' Get layer to be used as feature selection layer
            Set featureLyr = Map1.Layers(searchFeatureLayerCombo.Text)
            pt.Set X1, Y1
            ' Get feature user wants to use in search, based on where
            ' the clicked
            Set curFeatures = featureLyr.SearchAtPoint(pt)
            ' if a feature is found, set a variable to it
            If curFeatures.Count > 0 Then
                Set obj = curFeatures(1)
            Else
            ' display message telling user that they missed a feature for the
            ' layer they specified as the feature Search Layer
                MsgBox "No features in collection"
                Exit Sub
            End If
            ' Perform search for objects that lie within feature chosen
            Set curFeatures = searchLayer.SearchWithinFeature(obj, searchType)
            ' Add results of search to results list box control
            For Each obj In curFeatures
                searchResultsList.AddItem obj.Name & "  id: " & obj.FeatureID
            Next
            ' If menu item to add results to selection is true, the replace
            ' the selection for that layer with search results
            If add2selectionMenuItem.Checked = True Then
                searchLayer.Selection.Replace curFeatures
            End If
            
            ' Clear object Variables
            Set pt = Nothing
            Set curFeatures = Nothing
            Set obj = Nothing
            Set featureLyr = Nothing
        Case SEARCH_POINT_TOOL
            searchResultsList.Clear
            ' Assign point values where user clicked
            pt.Set X1, Y1
            ' Perform search
            Set curFeatures = searchLayer.SearchAtPoint(pt)
            ' Add results of search to results list box control
            For Each obj In curFeatures
                searchResultsList.AddItem obj.Name & "  id: " & obj.FeatureID
            Next
            ' If menu item to add results to selection is true, the replace
            ' the selection for that layer with search results
            If add2selectionMenuItem.Checked = True Then
                searchLayer.Selection.Replace curFeatures
            End If
            
            ' Clear object Variables
            Set pt = Nothing
            Set curFeatures = Nothing
            Set obj = Nothing
        Case Else
    End Select 'End Case
    Exit Sub
ErrHand:
    MsgBox Err.Description
End Sub

Private Sub panToolMenuItem_Click()
    'set pan tool to be active tool
    Map1.CurrentTool = miPanTool
End Sub

Private Sub searchDistanceMenuItem_Click()
    'set custom search tool to be active tool
    Map1.CurrentTool = SEARCH_DISTANCE_TOOL
End Sub

Private Sub searchFeatureMenuItem_Click()
    'set custom search tool to be active tool
    Map1.CurrentTool = SEARCH_FEATURE_TOOL
End Sub

Private Sub searchLayerListCombo_Click()
    Set searchLayer = Map1.Layers(searchLayerListCombo.Text)
End Sub

Private Sub searchPointMenuItem_Click()
    'set custom search tool to be active tool
    Map1.CurrentTool = SEARCH_POINT_TOOL
End Sub

Private Sub searchRectangleMenuItem_Click()
    'set custom search tool to be active tool
    Map1.CurrentTool = SEARCH_RECTANGLE_TOOL
End Sub

Private Sub zoomInToolMenuItem_Click()
    'Set zoom in tool to be active tool
    Map1.CurrentTool = miZoomInTool
End Sub

Private Sub zoomOutToolMenuItem_Click()
    'Set zoom out tool to be active tool
    Map1.CurrentTool = miZoomOutTool
End Sub

Public Sub updateControls()
    If Map1.Layers.Count > 0 Then
        Dim lyr As MapXLib.Layer
        searchLayerListCombo.Clear
        searchFeatureLayerCombo.Clear
        For Each lyr In Map1.Layers
            searchLayerListCombo.AddItem lyr.Name
            searchFeatureLayerCombo.AddItem lyr.Name
        Next
        searchLayerListCombo.ListIndex = 0
        searchFeatureLayerCombo.ListIndex = 0
        Set searchLayer = Map1.Layers(searchLayerListCombo.Text)
        
        Set lyr = Nothing
    End If
End Sub