O
okgxsh
Unregistered / Unconfirmed
GUEST, unregistred user!
查找最近的实体[转帖]
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 Asdo
uble, ByVal dblY Asdo
uble, ByVal sngRadius As Single, _
strItemName As String, X1 Asdo
uble, Y1 Asdo
uble, X2 Asdo
uble, Y2 Asdo
uble) 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,do
uble 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 youdo
n'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 Asdo
uble, ByVal Y1 Asdo
uble, ByVal X2 Asdo
uble, ByVal Y2 Asdo
uble, ByVal Distance Asdo
uble, 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 Asdo
uble
Dim ya Asdo
uble
Dim xb Asdo
uble
Dim yb Asdo
uble
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
//SelectByRadius不知道如何用
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 Asdo
uble, ByVal dblY Asdo
uble, ByVal sngRadius As Single, _
strItemName As String, X1 Asdo
uble, Y1 Asdo
uble, X2 Asdo
uble, Y2 Asdo
uble) 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,do
uble 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 youdo
n'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 Asdo
uble, ByVal Y1 Asdo
uble, ByVal X2 Asdo
uble, ByVal Y2 Asdo
uble, ByVal Distance Asdo
uble, 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 Asdo
uble
Dim ya Asdo
uble
Dim xb Asdo
uble
Dim yb Asdo
uble
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
//SelectByRadius不知道如何用