盒子论坛 v2.1

各位大佬：

我在程序中使用IdIcmpClient控件进行IP的PING检测，代码如下：

    IdIcmpClient1.host:='10.2.10.150';
    IdIcmpClient1.Ping() ;

    if (IdIcmpClient1.ReplyStatus.FromIpAddress <> '0.0.0.0') then
    begin
       ShowMessage('成功');
    end else
    begin
       ShowMessage('失败');
    end;

因为是公司的电脑，所有电脑都没有管理员权限，因此报10013错误，奇怪的是WIN10系统正常,只有WIN7或以下的系统才报错。

但是使用CMD进行PING功能又可以，我想请教一下各位，有什么好的解决方案吗？
----------------------------------------------
【个人签名】：玩了多年DELPHI,终于从菜鸟升级成老菜鸟

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/6/29 10:33:11

1楼：

Try use "TIdIcmpClient"

...  FMX project for test, but you can use in VCL!!!!

....
uses
  ...,
  IdBaseComponent,
  IdComponent,
  IdRawBase,
  IdRawClient,
  IdIcmpClient;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    BtnPING: TButton;
    Memo1: TMemo;
    SpinBox1: TSpinBox;
    Label1: TLabel;
    IdIcmpClient1: TIdIcmpClient;
    Label2: TLabel;
    Timer1: TTimer;
    procedure BtnPINGClick(Sender: TObject);
    procedure IdIcmpClient1Reply(ASender: TComponent; const AReplyStatus: TReplyStatus);
    procedure IdIcmpClient1Status(ASender: TObject; const AStatus: TIdStatus; const AStatusText: string);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  IdGlobal;

{$R *.fmx}

var
  MyCounterPings: integer = 0;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Timer1.Enabled := false;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Timer1.Enabled := false;
end;

procedure TForm1.BtnPINGClick(Sender: TObject);
begin
  Timer1.Enabled := false;
  //
  if Edit1.Text.IsEmpty then
    begin
      ShowMessage('Type a address valid to test. Ex.: www.google.com');
      //
      exit;
    end;
  //
  MyCounterPings := 0;
  //
  IdIcmpClient1.IPVersion      := Id_IPv4;
  IdIcmpClient1.Port          := 0;
  IdIcmpClient1.ReceiveTimeout := 500; // 500ms
  IdIcmpClient1.Host          := Edit1.Text;
  //
  Timer1.Interval := (IdIcmpClient1.ReceiveTimeout + 50);
  //
  // ----------
  // Timer1.Enabled  := true;  // ping by Timer1
  //
  // or
  //
  IdIcmpClient1.Ping; // ping directly!!!
  // ----------
end;

procedure TForm1.IdIcmpClient1Reply(ASender: TComponent; const AReplyStatus: TReplyStatus);
begin
  TThread.Synchronize(nil,
    procedure
    begin
      Memo1.Lines.Add(          { }
        'Time: ' + AReplyStatus.MsRoundTripTime.ToString + ' - ' +         { }
        'Msg: ' + AReplyStatus.Msg + ' - ' +          { }
        'Bytes received: ' + AReplyStatus.BytesReceived.ToString + ' - ' + { }
        'From: ' + AReplyStatus.FromIpAddress + ' - ' +          { }
        'To: ' + AReplyStatus.ToIpAddress + ' - ' +          { }
        'Redirect to: ' + AReplyStatus.RedirectTo + ' - ' +          { }
        'Msg type: ' + AReplyStatus.MsgType.ToString + ' - ' +          { }
        'Msg code: ' + AReplyStatus.MsgCode.ToString + ' - ' +          { }
        'Seq ID: ' + AReplyStatus.SequenceId.ToString + ' - ' +          { }
        'TTL: ' + AReplyStatus.TimeToLive.ToString + ' - ' +          { }
        'Packet Number: ' + AReplyStatus.PacketNumber.ToString          { }
        );
    end);
end;

procedure TForm1.IdIcmpClient1Status(ASender: TObject; const AStatus: TIdStatus; const AStatusText: string);
begin
  TThread.Synchronize(nil,
    procedure
    begin
      Memo1.Lines.Add('Status: ' + AStatusText);
    end);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  inc(MyCounterPings);
  //
  if (MyCounterPings = Trunc(SpinBox1.Value)) then
    Timer1.Enabled := false;
  //
  IdIcmpClient1.Ping;
end;

end.
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/6/29 10:34:29

2楼：

screenshot...
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

bluestorm8 (bluestorm)	▲▲△△△	-
	普通会员

2023/6/29 11:59:39

3楼：

基于WinSock的Ping程序

https://blog.csdn.net/BlueStorm/article/details/109823368
----------------------------------------------
-

作者：

changfenglee (葫芦老四)	★☆☆☆☆	-
	普通会员

2023/6/29 14:52:13

4楼：

To：emailx45

非常感谢您的回复指点

目前实现PING的功能是没有问题的，我的程序已经实现，但因为受系统管理员权限的影响，导致PING功能在部分平台无法使用，而产生报错

我看了您写的代码，并且经过了尝试，问题依旧存在，如图

PING功能在WINDOWS10的系统中是正常的（所有电脑），但在WINDOWS7上就会报错

此帖子包含附件:

大小:12.0K

----------------------------------------------
【个人签名】：玩了多年DELPHI,终于从菜鸟升级成老菜鸟

作者：

changfenglee (葫芦老四)	★☆☆☆☆	-
	普通会员

2023/6/29 14:52:56

5楼：

而在WINDOWS10的系统上，运行是没有问题的。

此帖子包含附件:

大小:117.7K

----------------------------------------------
【个人签名】：玩了多年DELPHI,终于从菜鸟升级成老菜鸟

作者：

dorry (littlecat)	★☆☆☆☆	-
	盒子活跃会员

2023/6/29 17:25:50

6楼：

试试这个，
https://bbs.2ccc.com/attachments/2018/dorry_2018412115115.zip
----------------------------------------------
泱泱华夏十亿兵,国耻期待儿孙平,愿提十万虎狼旅,跃马扬刀灭东京!

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/6/29 21:32:35

7楼：

@changfenglee

Did you try run as ADMIN?

if run, then use the "Project - Options..." Execution Level... as ADmin
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

steven2 (steven)	▲▲▲▲▲	-
	普通会员

2023/7/1 11:02:13

8楼：

indy系列效果比较差，我常用syapse40版本。可以支持SSL哦。
----------------------------------------------
-

作者：

changfenglee (葫芦老四)	★☆☆☆☆	-
	普通会员

2023/7/3 10:39:55

9楼：

感谢大家给的各种意见，现在问题解决了，解决的方式为放弃INDY，使用WINSOCK进行PING功能，解决了Windows7系统因为没有管理员权限导致Ping出错，报10013问题，以下是代码，网上也可以查到：

function PingHost(HostIP: string): boolean;
type
  PIPOptionInformation = ^TIPOptionInformation;
  TIPOptionInformation = packed record
    TTL: Byte;
    TOS: Byte;
    Flags: Byte;
    OptionsSize: Byte;
    OptionsData: pchar;
  end;
  PIcmpEchoReply = ^TIcmpEchoReply;
  TIcmpEchoReply = packed record
    Address: DWORD;
    Status: DWORD;
    RTT: DWORD;
    DataSize: WORD;
    Reserved: WORD;
    Data: Pointer;
    Options: TIPOptionInformation;
  end;
  TIcmpCreateFile = function: THandle; stdcall;
  TIcmpCloseHandle = function(IcmpHandle: THandle): boolean; stdcall;
  TIcmpSendEcho = function(IcmpHandle: THandle; DestinationAddress: DWORD; RequestData: Pointer; RequestSize: WORD; RequestOptions: PIPOptionInformation; ReplyBuffer: Pointer; ReplySize: DWORD; Timeout: DWORD): DWORD; stdcall;
var
  hICMP: THandle;
  hICMPdll: THandle;
  IcmpCreateFile: TIcmpCreateFile;
  IcmpCloseHandle: TIcmpCloseHandle;
  IcmpSendEcho: TIcmpSendEcho;
  pIPE: PIcmpEchoReply; //   ICMP   Echo   reply   buffer
  FIPAddress: DWORD;
  FSize: DWORD;
  FTimeOut: DWORD;
  BufferSize: DWORD;
  pReqData, pRevData: pchar;
  MyString: string;
begin
  result := false;
  hICMPdll := LoadLibrary('icmp.dll');
  if hICMPdll = 0 then
    Exit;
  @IcmpCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
  @IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');
  @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
  hICMP := IcmpCreateFile;
  if (hICMP = INVALID_HANDLE_VALUE) then Exit;
  //uses winsock;
  FIPAddress := inet_addr(pchar(HostIP)); //Delphi xe:  inet_addr(PANSIChar(ansistring(HostIP)));
  MyString := 'Hello TaoRoy'; //send data buffer
  pReqData := pchar(MyString);
  FSize := 40; //receive data buffer
  BufferSize := SizeOf(TIcmpEchoReply) + FSize;
  GetMem(pIPE, BufferSize);
  FillChar(pIPE^, SizeOf(pIPE^), 0);
  GetMem(pRevData, FSize);
  pIPE^.Data := pRevData;
  FTimeOut := 50; //超时间隔毫秒
  try
    result := IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString), nil, pIPE, BufferSize, FTimeOut) > 0;
  finally
    IcmpCloseHandle(hICMP);
    FreeLibrary(hICMPdll);
    FreeMem(pRevData);
    FreeMem(pIPE);
  end;
end;

调用函数：
var
  MyState:Boolean;
Begin
  MyState:=PingHost('10.2.10.150');
  if MyState then XXXXX ;
----------------------------------------------
【个人签名】：玩了多年DELPHI,终于从菜鸟升级成老菜鸟

作者：

bluestorm8 (bluestorm)	▲▲△△△	-
	普通会员

2023/7/3 13:30:49

10楼：

我以前试过用indy来ping, 发现其时延数据和windows系统里面的ping的时延对不上的, 后来改用了winSock才对的上.
----------------------------------------------
-

作者：

ivys (爬山虎)	★☆☆☆☆	-
	普通会员

2024/4/5 12:06:18

11楼：

最近正好遇到了这个问题，感谢分享。
----------------------------------------------
聪明的程序员用Delphi

信息

登陆以后才能回复