Форум по Delphi программированию



Вернуться   Форум по Delphi программированию > Разное > Исходники и статьи
Ник
Пароль
Регистрация <<         Правила форума         >> FAQ Пользователи Календарь Поиск Сообщения за сегодня Все разделы прочитаны

Ответ
 
Опции темы Поиск в этой теме Опции просмотра
  #1  
Старый 02.08.2015, 14:57
Аватар для Admin
Admin Admin вне форума
Администратор
 
Регистрация: 03.10.2005
Адрес: Россия, Москва
Сообщения: 1,540
Версия Delphi: Delphi 7
Репутация: выкл
По умолчанию [ Исходник ] - Пинг сети



Код:
(*
  Simple web server exemple

  tdjprog 1998 - 2015
  tdjprog@yahoo.fr
*)

unit Main;

interface

uses
  Windows, Messages, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls,
  SysUtils, Classes, IdIcmpClient, IdBaseComponent, IdComponent, IdRawBase, IdRawClient;


type
  TfrmPing = class(TForm)
    Panel1: TPanel;
    btPing: TButton;
    mReplies: TMemo;
    btStop: TButton;
    edHosts: TEdit;
    procedure btPingClick(Sender: TObject);
    procedure btStopClick(Sender: TObject);
  private
    procedure OnThreadPingTerminate(Sender: TObject);
  public
  end;

  TPing = class (TThread)
  private
    FPing: TIdIcmpClient;
    FPingResult: String;

    function GetPHost: String;
    procedure PingReplay(ASender: TComponent; const ReplyStatus: TReplyStatus);
  protected
    procedure DoPingHost;
    procedure Execute; override;
  public
    constructor Create(const PAddr: String; OnTerminateEvent: TNotifyEvent);
    destructor Destroy; override;

    property PResults: String read FPingResult;
    property PHost: String read GetPHost;
  end;

var
  frmPing: TfrmPing;
  StopThreads: Boolean = False;

implementation
{$R *.DFM}

function TPing.GetPHost: String;
begin
  Result:= '';
  if Assigned(FPing) then
    Result:= FPing.Host;
end;

procedure TPing.PingReplay(ASender: TComponent; const ReplyStatus: TReplyStatus);
var
  sTime: string;
begin         
  // TODO: check for error on ping reply (ReplyStatus.MsgType?)
  if (ReplyStatus.MsRoundTripTime = 0) then
    sTime := '<1'
  else
    sTime := '=';

  FPingResult:= Format('%s%d bytes from %s: icmp_seq=%d ttl=%d time%s%d ms',
                      [FPingResult,
                       ReplyStatus.BytesReceived,
                       ReplyStatus.FromIpAddress,
                       ReplyStatus.SequenceId,
                       ReplyStatus.TimeToLive,
                       sTime,
                       ReplyStatus.MsRoundTripTime]) + #13#10;
end;

constructor TPing.Create(const PAddr: String; OnTerminateEvent: TNotifyEvent);
begin
  inherited Create(True);
  
  FreeOnTerminate      := True;
  OnTerminate          := OnTerminateEvent;

  FPing                := TIdIcmpClient.Create(nil);
  FPing.ReceiveTimeout := 1000;
  FPing.Host           := PAddr;
  FPing.OnReply        := PingReplay;
  //FAddr                := PAddr;
  FPingResult          := '';
end;

destructor TPing.Destroy;
begin
  if Assigned(FPing) then
    FPing.Free;
    
  inherited Destroy;
end;

procedure TPing.DoPingHost;
begin
  FPing.Ping;
  Application.ProcessMessages;
end;

procedure TPing.Execute;
var i: Byte;
begin
  i:= 1;
  while (i <= 4) and (not Terminated) and (not StopThreads) do
  begin
    Synchronize(DoPingHost);
    Inc(i);
  end;
end;

procedure TfrmPing.OnThreadPingTerminate(Sender: TObject);
begin
  with (Sender as TPing) do
  begin
    mReplies.Lines.Add(Format('Host [%s]', [PHost]));
    mReplies.Lines.Add(Format('%s', [PResults]));
  end;
end;

procedure TfrmPing.btPingClick(Sender: TObject);
var i: Integer;
begin
  StopThreads:= False;
  for i:= 210 to 230 do
  begin
    if StopThreads then
      Break;

    with TPing.Create(Format(edHosts.Text, [i]), OnThreadPingTerminate) do
      Resume;

    Application.ProcessMessages;
  end;
end;

procedure TfrmPing.btStopClick(Sender: TObject);
begin
  StopThreads:= True;
end;

end.

Автор: cs_AccessToYou
Ссылка: http://codes-sources.commentcamarche...101103/1374211
Ответить с цитированием
Этот пользователь сказал Спасибо Admin за это полезное сообщение:
M.A.D.M.A.N. (02.08.2015)
Ответ



Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск
Опции просмотра

Ваши права в разделе
Вы не можете создавать темы
Вы не можете отвечать на сообщения
Вы не можете прикреплять файлы
Вы не можете редактировать сообщения

BB-коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.
Быстрый переход


Часовой пояс GMT +3, время: 01:31.


 

Сайт

Форум

FAQ

RSS лента

Прочее

 

Copyright © Форум "Delphi Sources" by BrokenByte Software, 2004-2021

ВКонтакте   Facebook   Twitter   Ссылка на Telegram