查找最近的实体? 谁能把vb代码转换成delphi 或者 有delphi版的代码(就剩这么几分了)(20分)

  • 主题发起人 主题发起人 okgxsh
  • 开始时间 开始时间
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不知道如何用
 
For Each ft In objMap.Layers(strSearchLayer).Selection
这句如何转换!兄弟们帮帮我!up 几个也
 
for i:=1 to objMap.Layers(strSearchLayer).Selection.countdo

begin

if ft=objMap.Layers(strSearchLayer).Selection.Items;
...
end;

这样差不多就可以的。我用过的
 
首先强烈感谢yostgxf的多次回答问题!在下表示衷心的十二万份的感谢!!!
还有一个问题:在循环的时候出现错误

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,OleCtrls ,MapXLib_TLB,comobj;

type
TForm1 = class(TForm)
Button1: TButton;
Map1: TMap;
Button2: TButton;
text1: TEdit;
Button3: TButton;
ListBox2: TListBox;
Button4: TButton;
Button5: TButton;
Button6: TButton;
L1: TListBox;
Button7: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Map1ToolUsed(Sender: TObject;
ToolNum: Smallint;
X1, Y1, X2,
Y2, Distance:do
uble;
Shift, Ctrl: WordBool;
var EnableDefault: WordBool);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
private
{ Private declarations }
public
Function nearest(var strsearchlayer:string;var dblx:double;var dbly:double;var sngradius:single;stritemname:string;var x1 :double;var y1:double;
var x2:double var y2:double) :integer;

{ Public declarations }
end;


var
Form1: TForm1;

implementation

{$R *.dfm}
Function tform1.nearest(var strsearchlayer:string;var dblx:double;var dbly:double;var sngradius:single;stritemname:string;var x1 :double;var y1:double;
var x2:double var y2:double) :integer;
var
sngLowestDist,sngTemp : Single;
iTimesThrough : Integer;
ft : mapxlib_tlb.Feature;
rect :mapxlib_tlb.Rectangle;
i,first : Integer;
F : CMapXFeature;
Slc : OleVariant;
MinDistance :do
uble;
SearchTimes : Integer;
begin

sngLowestDist:=0;
itimesthrough:=1;
//循环次数累计
repeat
Map1.Layers.Item(strsearchlayer).Selection.selectbyradius(dblx,dbly,sngradius,miselectionnew);
sngradius:=sngradius*2;
itimesthrough:=itimesthrough+1;
until
(Map1.Layers.Item(strsearchlayer).Selection.Count > 0) Or (iTimesThrough > 10);
If Map1.Layers.Item(strSearchLayer).Selection.Count = 0 then

begin

Nearest := 0;
Exit;
end
else


begin

first := 1;
for i:=1 to map1.Layers.item(strSearchLayer).Selection.countdo

begin

try //循环时出现错误 为何??
ft:=map1.Layers.item(strSearchLayer).Selection.Item(i)
EXCEPT
showmessage('ft');
end;

sngTemp := Map1.Distance(dblX, dblY, ft.CenterX, ft.CenterY);


If (sngTemp < sngLowestDist) then
//(first=1) Or
begin

TRY
sngLowestDist := sngTemp
strItemName := ft.Name;

X1 := ft.Bounds.XMin;
Y1 := ft.Bounds.YMin;
X2 := ft.Bounds.XMax;
Y2 := ft.Bounds.YMax;
EXCEPT
SHOWMESSAGE('INEERO');
end;

//showmessage(ft.name);
L1.Items.Add(ft.name);
end;

first := 0;
Next;
Map1.Layers.Item(strSearchLayer).Selection.ClearSelection;
Nearest := 1;
end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin

Map1.CurrentTool := 101
end;


procedure TForm1.FormCreate(Sender: TObject);
begin

Map1.CreateCustomTool (101, miToolTypePoint, miRadiusSelectCursor, EmptyParam, EmptyParam, EmptyParam);
end;


procedure TForm1.Button2Click(Sender: TObject);
begin

map1.CurrentTool:=mizoomintool;
end;


procedure TForm1.Map1ToolUsed(Sender: TObject;
ToolNum: Smallint;
X1, Y1,
X2, Y2, Distance:do
uble;
Shift, Ctrl: WordBool;
var EnableDefault: WordBool);
var
Radius : Single;
itemName : String;
xa :do
uble
ya :do
uble
xb :do
uble
yb :do
uble;
strLyr : String
begin

strLyr := 'US Major Cities';
If ToolNum = 101 then

begin

Radius := 500
If Nearest(strLyr,X1,Y1,Radius,itemName,xa,ya,xb,yb)>0 then

Text1.Text := itemName
else

Text1.Text := 'No Major City near there!';
end;

End
 
Selection好像没有Items属性。
这样吧,你定义一个Features变量,把找到的东西赋给它
例:var fts:Features;
fts:=map1.Layers.item(strSearchLayer).SearchWithinRectangle或SearchWithinDistance或SearchAtPoint函数
然后用fts代替你的所有Selection。
祝你成功
 
for i:=1 to map1.Layers.item(strSearchLayer).Selection.countdo

begin
//把这个begin
去掉就不会有错误了,不知道为何??
try //循环时没有错误
ft:=map1.Layers.item(strSearchLayer).Selection.Item(i)
EXCEPT
showmessage('ft');
end;

sngTemp := Map1.Distance(dblX, dblY, ft.CenterX, ft.CenterY);
/////////////////////////////////////////////////////////////
另外Selection没有 items 只能用item 即:Selection.Item(i)

//////////////////////////////////////////////////////////
If (sngTemp < sngLowestDist) then
//(first=1) Or
begin

TRY
sngLowestDist := sngTemp
strItemName := ft.Name;

X1 := ft.Bounds.XMin;
Y1 := ft.Bounds.YMin;
X2 := ft.Bounds.XMax;
Y2 := ft.Bounds.YMax;
EXCEPT
SHOWMESSAGE('INEERO');
end;

//////////////////////////////////////////////////////////////
但是现在我对各个点计算距离远近时,还没找到方法!上述排序是否有问题!我总觉得这种排序不对!!
 
另外:画折线时如何计算距离?是不是吧各个节点保存到数据表中,然后再计算两个点的距离相加???
 
画折线时,画完一段计算一段就行了,累加。
 
接受答案了.
 
后退
顶部