VB + MapX 查找最近的图元

 

Private Sub Command1_Click()
Map1.CurrentTool = 101
End Sub

Private Sub cmdQuit_Click()
End
End Sub

Public Function Nearest(ByVal objMap As Map, ByVal strSearchLayer As String, _
ByVal dblX As Double, ByVal dblY As Double, ByVal sngRadius As Single, _
strItemName As String, X1 As Double, Y1 As Double, X2 As Double, Y2 As Double) As Integer
' Returns the name and location of the closest item from the search layer.
' objMap: the MapX object containing the search layer
' strSearchLayer: The layer being searched
' dblX,dblY: Coordinates of where to center the search
' sngRadius: the initial size ring in km MapX will select from within
' strItemName: Name of closest feature item
' x1,y1,x2,y2: Coordinates of closest feature item
Dim sngLowestDist As Single, sngTemp As Single
Dim iTimesThrough As Integer
Dim ft As New MapXlib.Feature
Dim rect As New MapXlib.Rectangle
Dim first As Integer

'Select all of the objects within Radius km of dblX,Y
'If there's nothing there, double the radius and try again.
'Repeat until something is found, or we ran through this 10 times
iTimesThrough = 1
Do
'execute the SelectByRadius method of MapX
objMap.Layers(strSearchLayer).Selection.SelectByRadius dblX, dblY, sngRadius, miSelectionNew
'Double the radius for the next search (if needed)
sngRadius = sngRadius * 2
'Increment our counter
iTimesThrough = iTimesThrough + 1

Loop Until objMap.Layers(strSearchLayer).Selection.Count > 0 Or iTimesThrough > 10
'Test to see if there was anything selected
If objMap.Layers(strSearchLayer).Selection.Count = 0 Then
Nearest = False
Exit Function
End If
'Find closest feature in selection collection
first = True
For Each ft In objMap.Layers(strSearchLayer).Selection
'get the distance to the selected object
sngTemp = objMap.Distance(dblX, dblY, ft.CenterX, ft.CenterY)
'is this closest so far?
If first Or (sngTemp < sngLowestDist) Then
' replace feature details
sngLowestDist = sngTemp
strItemName = ft.Name
' rect = ft.bounds
X1 = ft.Bounds.XMin
Y1 = ft.Bounds.YMin
X2 = ft.Bounds.XMax
Y2 = ft.Bounds.YMax
End If
first = False
Next
'Clear the selection so that you don't see the highlight pattern
objMap.Layers(strSearchLayer).Selection.ClearSelection
' return success
Nearest = True
End Function

Private Sub Form_Load()
Map1.CreateCustomTool 101, miToolTypePoint, miRadiusSelectCursor
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)
If ToolNum = 101 Then
Dim Radius As Single
Dim itemName As String
Dim xa As Double
Dim ya As Double
Dim xb As Double
Dim yb As Double
Dim strLyr As String
strLyr = "US Major Cities"
Radius = 500
If (Nearest(Map1, strLyr, X1, Y1, Radius, itemName, xa, ya, xb, yb)) Then
Text1 = itemName
Else
Text1 = "No Major City near there!"
End If
End If
End Sub

========使用Find.search精确查询某个图元=====

Private Sub Command1_Click()
Dim lyr As MapXLib.Layer
Dim ds As MapXLib.Dataset
Dim findftr As MapXLib.FindFeature
Dim ftr As MapXLib.Feature

Set lyr = Map1.Layers(1)
Set ds = Map1.Datasets.Add(miDataSetLayer, lyr)
Set lyr.Find.FindDataset = ds
Set lyr.Find.FindField = ds.Fields("name")
Set findftr = lyr.Find.Search("开发区管委会")
If (findftr.FindRC Mod 10 = 1) Then
Set ftr = lyr.GetFeatureByKey(findftr.FeatureKey)
lyr.Selection.Replace ftr
Map1.ZoomTo Map1.Zoom, ftr.CenterX, ftr.CenterY
End If

End Sub

======

使用layer.find进行精确查找

============

Private Sub Command2_Click()
Dim FindObj As MapXLib.Find
     Dim FoundFeature As FindFeature
     '从要查询的RTU图层生成Find对象，并为这个对象设置要查询的FindDataSet、FindField属性
     Set FindObj = Form1.Map1.Layers.Item(1).Find
     Set FindObj.FindDataset = Form1.Map1.DataSets("RTU节点" & " dataset")
     Set FindObj.FindField = FindObj.FindDataset.Fields("RTUName")
           
     Set FoundFeature = FindObj.Search(Text1.Text)
      
     If FoundFeature.FindRC Mod 10 = 1 Or FoundFeature.FindRC Mod 10 = 2 Then
         Me.Hide
         ' 关掉AutoRedraw是因为CenterX(Y)的改变就要刷新图层，AutoRedraw打开的话会造成二次刷新
         Form1.Map1.AutoRedraw = False
         Form1.Map1.CenterX = FoundFeature.CenterX
         Form1.Map1.CenterY = FoundFeature.CenterY
         Form1.Show
     Else
         MsgBox "不存在该RTU节点！"
     End If

End Sub

===============

使用layer.search模糊查询若干图元

================

开发环境：VB6+mapx4.5+win2000

代码：

附注：必须miDatasetLayer绑定；字段可以无索引；图层可以不注册。

Private Sub Command2_Click()
Dim lyr As MapXLib.Layer
Dim ds As MapXLib.Dataset
Dim ftrs As MapXLib.Features
Dim ftr As MapXLib.Feature

Set lyr = Map1.Layers(1)
Set ds = Map1.Datasets.Add(miDataSetLayer, lyr)
Set ftrs = lyr.Search("name like ""%开发区%""")

For Each ftr In ftrs
lyr.Selection.Add ftr
Map1.Bounds = Map1.Layers.Bounds
Next
End Sub