技术资料：查找最近的实体

百花草

技术资料：查找最近的实体
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

fugangxx

谢谢分享

49130

好呀，收下了

jxqkd123

探矿者件可以提高矿体的命中率，减少找矿的成本和难度，主要功能：数据管理、二维制图、三维建模、储量估算、三维立体预测等，有需要免费试用可以联系负责人邓帅15377311476（微信同号），软件针对单位或者企业试用，不面向个人试用