Мастера DELPHI, Delphi programming community Рейтинг@Mail.ru Титульная страница Поиск, карта сайта Написать письмо 
| Новости |
Новости сайта
Поиск |
Поиск по лучшим сайтам о Delphi
FAQ |
Огромная база часто задаваемых вопросов и, конечно же, ответы к ним ;)
Статьи |
Подборка статей на самые разные темы. Все о DELPHI
Книги |
Новинки книжного рынка
Новости VCL
Обзор свежих компонент со всего мира, по-русски!
|
| Форумы
Здесь вы можете задать свой вопрос и наверняка получите ответ
| ЧАТ |
Место для общения :)
Орешник |
Коллекция курьезных вопросов из форумов
KOL и MCK |
KOL и MCK - Компактные программы на Delphi
Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / rsdn.org

 
Чтобы не потерять эту дискуссию, сделайте закладку « предыдущая ветвь | форум | следующая ветвь »

Нужно сделать ping на Delphi [D7, WinXP]


apic   (26.06.18 11:41

Всем доброго времени суток! Задача избитая, но полноценного решения не нашел. Нужно сделать ping на Delphi. Нашел вроде хороший пример http://www.delphimaster.ru/articles/icmp.html , но не хватает мозгов как сделать, что бы размер буффера можно бло указывать произвольно? Не хватает мозгов переделать на динамический массив буффера данных. Кроме того хотелось бы услышать мнение по правильности этого кода, есть мнение, что этот код может вызывать утечки памяти... И еще интересно - в Delphi XE случайно не сделали "обертку" под использование функций из ICMP.DLL?


megavoid ©   (26.06.18 12:49[1]

Именно на дельфи принципиально? В других языках можно сделать подключением библиотеки в одну-две строчки.
https://github.com/geerlingguy/Ping


apic   (26.06.18 13:50[2]

Да, мне нужно н Делфи. В общем вместо
pingBuffer : array [0..31] of AnsiChar;
я написал
pingBuffer : array of AnsiChar;
Потом инициализирую переменную
SetLength(pingBuffer, 1452);
и заменил везде
sizeof(pingBuffer)
на
Length(pingBuffer)
Адрес массива передаю также:
pIpe.Data := @pingBuffer;
Вроде все работает, но вопрос - правильно ли я все сделал? Больше всего волнует вопрос: передача адреса на статический и динамический массив одинаково выполняется в Делфи? Я имею ввиду синтаксически...


RWolf ©   (26.06.18 14:48[3]

Неодинаково.
@StaticArr = @StaticArr[0] — указатель на первый элемент
@DynArr[0] — указатель на первый элемент
@DynArr — указатель на указатель на первый элемент


apic   (26.06.18 15:08[4]

Спасибо! Подправил


apic   (05.07.18 07:04[5]

Люди добрые а как переделать этот пример http://www.delphimaster.ru/articles/icmp.html что бы добавить поддержку IPv6?


megavoid ©   (06.07.18 10:01[6]

Icmp6CreateFile, Icmp6SendEcho2, Icmp6ParseReplies
https://docs.microsoft.com/en-us/windows/desktop/api/icmpapi/nf-icmpapi-icmp6createfile


cryptologic ©   (16.08.18 02:10[7]

unit Pings;

interface

USES windows, WinSock, Error;

type

  //TPingParamOut = ();

   ip_option_information = packed record  // Информация заголовка IP (Наполнение
      // этой структуры и формат полей описан в RFC791.
       Ttl : byte;             // Время жизни (используется traceroute-ом)
       Tos : byte;             // Тип обслуживания, обычно 0
       Flags : byte;           // Флаги заголовка IP, обычно 0
       OptionsSize : byte;     // Размер данных в заголовке, обычно 0, максимум 40
       OptionsData : Pointer;  // Указатель на данные
   end;

  icmp_echo_reply = packed record
       Address : u_long;                // Адрес отвечающего
       Status : u_long;                 // IP_STATUS (см. ниже)
       RTTime : u_long;                 // Время между эхо-запросом и эхо-ответом
                                        // в миллисекундах
       DataSize : u_short;              // Размер возвращенных данных
       Reserved : u_short;              // Зарезервировано
       Data : Pointer;                  // Указатель на возвращенные данные
       Options : ip_option_information; // Информация из заголовка IP
   end;

   PIPINFO = ^ip_option_information;
   PVOID = Pointer;

var
 ping_error: DWORD;
 Ping_error_message: string;

function IcmpCreateFile() : THandle; stdcall; external 'ICMP.DLL' name 'IcmpCreateFile';
function IcmpCloseHandle(IcmpHandle : THandle) : BOOL; stdcall; external 'ICMP.DLL'  name 'IcmpCloseHandle';
function IcmpSendEcho(
                     IcmpHandle : THandle;    // handle, возвращенный IcmpCreateFile()
                     DestAddress : u_long;    // Адрес получателя (в сетевом порядке)
                     RequestData : PVOID;     // Указатель на посылаемые данные
                     RequestSize : Word;      // Размер посылаемых данных
                     RequestOptns : PIPINFO;  // Указатель на посылаемую структуру
                                                  // ip_option_information (может быть nil)
                     ReplyBuffer : PVOID;     // Указатель на буфер, содержащий ответы.
                     ReplySize : DWORD;       // Размер буфера ответов
                     Timeout : DWORD          // Время ожидания ответа в миллисекундах
                     ) : DWORD; stdcall; external 'ICMP.DLL' name 'IcmpSendEcho';

function GetPing(HostName: String): Integer;

implementation

function GetPing(HostName: String): Integer;
var
   hIP : THandle;
   pingBuffer : array [0..31] of Char;
   pIpe : ^icmp_echo_reply;
   pHostEn : PHostEnt;
   wVersionRequested : WORD;
   lwsaData : WSAData;
   error : DWORD;
   destAddress : In_Addr;
   ping: Integer;
begin

   // Создаем handle
   hIP    := IcmpCreateFile();
   Result := -1;

   GetMem(pIpe, sizeof(icmp_echo_reply) + sizeof(pingBuffer));
   pIpe.Data     := @pingBuffer;
   pIpe.DataSize := sizeof(pingBuffer);

   wVersionRequested := MakeWord(1,1);
   error := WSAStartup(wVersionRequested, lwsaData);
   if (error <> 0) then
   begin
     ping_error := error;
     Ping_error_message := 'Error: WSAStartup() to exit; ' + SystemErrorMessage(error);
     //mm.SetTextBuf('Error in call to ' + 'WSAStartup().');
     //mm.Lines.Add('Error code: '+IntToStr(error));
     Exit;
   end;

   pHostEn := gethostbyname(PAnsiChar(AnsiString(HostName)));
   error := GetLastError();
   if (error <> 0) then
   begin
     ping_error := error;
     Ping_error_message := 'Error: gethostbyname() to exit; ' + SystemErrorMessage(error);
     //mm.SetTextBuf('Error in call to' + 'gethostbyname().');
     //mm.Lines.Add('Error code: '+IntToStr(error));
     Exit;
   end;

   destAddress := PInAddr(pHostEn^.h_addr_list^)^;

  // Посылаем ping-пакет
  //mm.Lines.Add('Pinging ' + pHostEn^.h_name+' ['+ inet_ntoa(destAddress)+'] '+
  //             ' with '+ IntToStr(sizeof(pingBuffer)) + ' bytes of data:');

  IcmpSendEcho(hIP,
                destAddress.S_addr,
                @pingBuffer,
                sizeof(pingBuffer),
                Nil,
                pIpe,
                sizeof(icmp_echo_reply) + sizeof(pingBuffer),
                500);

   error := GetLastError();
   if (error <> 0) then
   begin
     ping_error := error;
     Ping_error_message := 'Error: IcmpSendEcho() to exit; '  + SystemErrorMessage(error);
     //mm.SetTextBuf('Error in call to ' + 'IcmpSendEcho()');
     //mm.Lines.Add('Error code: '+IntToStr(error));
     Exit;
   end;

    // Смотрим некоторые из вернувшихся данных
   //mm.Lines.Add('Reply from '+
   //            IntToStr(LoByte(LoWord(pIpe^.Address)))+'.'+
   //            IntToStr(HiByte(LoWord(pIpe^.Address)))+'.'+
   //            IntToStr(LoByte(HiWord(pIpe^.Address)))+'.'+
   //            IntToStr(HiByte(HiWord(pIpe^.Address))));
   //mm.Lines.Add('Reply time: '+IntToStr(pIpe.RTTime)+' ms');

   Result := pIpe.RTTime;
   if Result = 0 then Result := 1;

   IcmpCloseHandle(hIP);
   WSACleanup();
   FreeMem(pIpe);
end;

end.


cryptologic ©   (16.08.18 02:13[8]

Пинг реализован в отдельном потоке (модуль может быть с ошибками)

unit ThrPings;

interface

uses
 System.Classes, System.SysUtils , Dialogs, Windows, WinSock, Error;

type
  //TPingParamOut = ();
   ip_option_information = packed record  // Информация заголовка IP (Наполнение
      // этой структуры и формат полей описан в RFC791.
       Ttl : byte;             // Время жизни (используется traceroute-ом)
       Tos : byte;             // Тип обслуживания, обычно 0
       Flags : byte;           // Флаги заголовка IP, обычно 0
       OptionsSize : byte;     // Размер данных в заголовке, обычно 0, максимум 40
       OptionsData : Pointer;  // Указатель на данные
   end;

  icmp_echo_reply = packed record
       Address : u_long;                // Адрес отвечающего
       Status : u_long;                 // IP_STATUS (см. ниже)
       RTTime : u_long;                 // Время между эхо-запросом и эхо-ответом
                                        // в миллисекундах
       DataSize : u_short;              // Размер возвращенных данных
       Reserved : u_short;              // Зарезервировано
       Data : Pointer;                  // Указатель на возвращенные данные
       Options : ip_option_information; // Информация из заголовка IP
   end;

   PIPINFO = ^ip_option_information;
   PVOID = Pointer;

type
 ThreadPings = class(TThread)
 private
   FHostName   : AnsiString;
   FPingResult : Integer;
   FInterval   : Word;
   procedure SetHosName(StrValue: String);
   procedure SetPingResult(IntValue: Integer);
   procedure SetInterval(IntValue: WORD);
   function GetInterval: WORD;
   function GetHostName: String;
   function GetPingResult: Integer;
 protected
   hIP               : THandle;
   pIpe              : ^icmp_echo_reply;
   wVersionRequested : WORD;
   lwsaData          : WSAData;
   pHostEn           : PHostEnt;
   destAddress       : In_Addr;
   error             : DWORD;
   pingBuffer : array [0..31] of Char;
   StrSendText: String;
   procedure SendMemo;
   procedure Execute; override;
 public
   LastErrorMessage: string;
   Property PingResult: Integer read GetPingResult write SetPingResult;
   Property HostName: string read GetHostName write SetHosName;
   Property Interval: WORD read GetInterval write SetInterval;
   procedure Ping;
   constructor Create;
   destructor Destroy; Override;
 end;

function IcmpCreateFile() : THandle; stdcall; external 'ICMP.DLL' name 'IcmpCreateFile';
function IcmpCloseHandle(IcmpHandle : THandle) : BOOL; stdcall; external 'ICMP.DLL'  name 'IcmpCloseHandle';
function IcmpSendEcho(
                     IcmpHandle : THandle;    // handle, возвращенный IcmpCreateFile()
                     DestAddress : u_long;    // Адрес получателя (в сетевом порядке)
                     RequestData : PVOID;     // Указатель на посылаемые данные
                     RequestSize : Word;      // Размер посылаемых данных
                     RequestOptns : PIPINFO;  // Указатель на посылаемую структуру
                                                  // ip_option_information (может быть nil)
                     ReplyBuffer : PVOID;     // Указатель на буфер, содержащий ответы.
                     ReplySize : DWORD;       // Размер буфера ответов
                     Timeout : DWORD          // Время ожидания ответа в миллисекундах
                     ) : DWORD; stdcall; external 'ICMP.DLL' name 'IcmpSendEcho';

implementation

USES UFrmMain;

constructor ThreadPings.Create;
begin
   inherited Create(True); //CreateSuspended

   hIP    := IcmpCreateFile();
   GetMem(pIpe, sizeof(icmp_echo_reply) + sizeof(pingBuffer));
   pIpe.Data := @pingBuffer;
   pIpe.DataSize := sizeof(pingBuffer);
   wVersionRequested := MakeWord(1,1);
   error := WSAStartup(wVersionRequested, lwsaData);
   if (error <> 0) then
   begin
     LastErrorMessage := 'Error: gethostbyname() ' + SystemErrorMessage(error);
     Terminate;
   end;
end;

destructor ThreadPings.Destroy;
begin
 IcmpCloseHandle(hIP);
 WSACleanup();
 FreeMem(pIpe);
 inherited;
end;

procedure ThreadPings.Execute;
var BgnTime: Cardinal;
begin
 NameThreadForDebugging('TPings');
 { Place thread code here }

 BgnTime := GetTickCount;
 While Not Terminated do
 begin

   if LastErrorMessage <> '' then Continue;

   if ((GetTickCount - BgnTime) div 1000) >= FInterval Then
   begin

     IcmpSendEcho(hIP,
                  destAddress.S_addr,
                  @pingBuffer,
                  sizeof(pingBuffer),
                  Nil,
                  pIpe,
                  sizeof(icmp_echo_reply) + sizeof(pingBuffer),
                  5000);

     error := GetLastError();
     if (error <> 0) then
     begin
       LastErrorMessage := 'Error: IcmpSendEcho() '  + SystemErrorMessage(error);
       Continue;
     end;

     if pIpe.RTTime = 0 then PingResult := 1
     else PingResult := pIpe.RTTime;

     StrSendText := 'Ping: '+IntToStr(PingResult);
     Synchronize(SendMemo);

     BgnTime := GetTickCount;

   end;
   sleep(50);

 end;
end;

function ThreadPings.GetHostName: String;
begin
 Result := FHostName;
end;

function ThreadPings.GetInterval: WORD;
begin
 Result := FInterval;
end;

function ThreadPings.GetPingResult: Integer;
begin
 Result := FPingResult;
end;

procedure ThreadPings.Ping;
begin
 Resume;
end;

procedure ThreadPings.SendMemo;
begin
 FrmMain.mm.lines.add(StrSendText);
end;

procedure ThreadPings.SetHosName(StrValue: String);
begin
 FPingResult      := 0;
 pHostEn := gethostbyname(PAnsiChar(AnsiString(StrValue)));
 error := GetLastError();
 if (error <> 0) then
 begin
   LastErrorMessage := 'Error: gethostbyname() ' + SystemErrorMessage(error);
   ShowMessage(LastErrorMessage);
   Exit;
 end;
 destAddress := PInAddr(pHostEn^.h_addr_list^)^;
 LastErrorMessage := '';
end;

procedure ThreadPings.SetInterval(IntValue: WORD);
begin
 FInterval := IntValue;
 if IntValue < 3 then FInterval := 3;
 if IntValue > 300 then FInterval := 300;
end;

procedure ThreadPings.SetPingResult(IntValue: Integer);
begin
 FPingResult := IntValue;
end;

end.


cryptologic ©   (16.08.18 02:30[9]

Пояснения модуля ThrPings работающего в потоке
Классический пример из поста cryptologic ©   (16.08.18 02:10) [7]  т.е. функцию function GetPing(HostName: String): Integer; ее части кода раскидал по процедурам класса потока:

1. выделение буфера  GetMem(pIpe, sizeof(icmp_echo_reply) + sizeof(pingBuffer)); вписал в метод ThreadPings.Create; а уничтожение буфера в destroy т.е. буфер создается один раз и используется на всем протяжении жизни потока.
И вот возникает проблема правомерно ли так делать? периодически вываливается ошибка о недостаточности ресурсов. Может нужно буфер создавать и освобождать при каждом вызове пинга? Кто встречался с подобным отпешитесь?


cryptologic ©   (16.08.18 02:35[10]

Модуль Error.pas для для обоих вышеупомянутых модулей
Позволяет получить локализованный  ответ об ошибке согласно установленной языковой версии windows

Unit Error;

interface

Uses Windows;

function SystemErrorMessage(ErrorCode: Integer): string;
function GetSysErrorMessage(ErrorCode: Integer): String;
procedure SaveErrorMessage(DebugMsg: String);

var
 LAST_ERROR_MESSAGE : String;

implementation

procedure SaveErrorMessage(DebugMsg: String);
begin
 if DebugMsg <> '' then
   LAST_ERROR_MESSAGE := DebugMsg+' '+GetSysErrorMessage(GetLastError)
 else LAST_ERROR_MESSAGE := GetSysErrorMessage(GetLastError)
end;

{------------------------- GetSysErrorMessage ---------------------------------}
function GetSysErrorMessage(ErrorCode: Integer): String;
Var s: string;
begin
 Str(ErrorCode:0,S);
 Result:='System Error. Code: '+s+' '+SystemErrorMessage(ErrorCode)+'.';
end;

{------------------------- SystemErrorMessage ---------------------------------}
function SystemErrorMessage(ErrorCode: Integer): string;
var
 Buffer : array[0..255] of Char;
 Len    : Integer;
begin
 Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or
                      FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
                      SizeOf(Buffer), nil);
 while (Len > 0) and (Buffer[Len - 1] in [ #0..#32, '.']) do Dec(Len);
 SetString(Result, Buffer, Len);
end;

end.


cryptologic ©   (16.08.18 02:53[11]

Почему пинг в отдельном потоке, потому что при отсутствии узла и цикличном пинговании у приложения возникают невероятные фризы
Мини инструкция как использовать модуль:

var Tpings: ThreadPings;

Tpings := ThreadPings.Create;     // Экземпляр потока создается в спящем режиме
TPings.Interval   := 3;           // здесь задается интервал пингования в секундах, мин. = 3 макс. = 300 секунд
TPings.HostName   := 'Yandex.ru'; // задаем хост для пинга
TPings.Ping;                      // стартуем пингование
TPings.PingResult // получаем ресультат пинга в типе integer если -1 то возникла ошибка ее смотрим TPings.LastErrorMessage, если более 0 то все норм.
mm.Lines.Add('TPings.PingResult: ' + IntToStr(TPings.PingResult)); // читаем результат пинга.


имя   (04.09.18 13:15[12]

Удалено модератором


Wonder ©   (19.10.18 19:58[13]

Офигеть! Через столько лет вспомнили нашу с Серегой статью про icmp. Только почему из авторов убрали Сергея?


версия для печати

Написать ответ

Ваше имя (регистрация  E-mail 







Разрешается использование тегов форматирования текста:
<b>жирный</b> <i>наклонный</i> <u>подчеркнутый</u>,
а для выделения текста программ, используйте <code> ... </code>
и не забывайте закрывать теги! </b></i></u></code> :)


Наверх

  Рейтинг@Mail.ru     Титульная страница Поиск, карта сайта Написать письмо