LANCE UN PING ET LE RECUPERE DANS UNE FENETRE STYLE FLASHGET

unit Main;

interface

uses
  Windows, Messages, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls,
  SysUtils, Classes, IdIcmpClient, IdBaseComponent, IdComponent, IdRawBase, IdRawClient,
  Gauges, ImgList, Buttons, XPMan, SkinCtrls, Menus, ComCtrls;


type
  TfrmPing = class(TForm)
    ICMP: TIdIcmpClient;
    TimerPing: TTimer;
    XPManifest1: TXPManifest;
    edtHost: TEdit;
    GaugePing: TGauge;
    btnPing: TSpeedButton;
    LabelPing: TLabel;
    spSkinLinkLabel1: TspSkinLinkLabel;
    PopupMenu1: TPopupMenu;
    mnModePlein: TMenuItem;
    mnModeReduit: TMenuItem;
    mnPing: TMenuItem;
    mnQuitter: TMenuItem;
    TrackBarAlpha: TTrackBar;
    procedure ICMPReply(ASender: TComponent; const ReplyStatus: TReplyStatus);
    procedure btnPingClick(Sender: TObject);
    procedure TimerPingTimer(Sender: TObject);
    procedure btStopClick(Sender: TObject);
    procedure spSkinLinkLabel1DblClick(Sender: TObject);
    procedure mnModeReduitClick(Sender: TObject);
    procedure mnModePleinClick(Sender: TObject);
    procedure mnQuitterClick(Sender: TObject);
    procedure mnPingClick(Sender: TObject);
    procedure TrackBarAlphaChange(Sender: TObject);
  private
  public
  end;

var
  frmPing: TfrmPing;

implementation
{$R *.DFM}
uses Shellapi;

procedure TfrmPing.ICMPReply(ASender: TComponent; const ReplyStatus: TReplyStatus);
var
  sHint, sTime: string;
  sGauge: integer;
begin
  // TODO: check for error on ping reply (ReplyStatus.MsgType?)
    sTime := '';
  sHint := Format('%s%d ms',[sTime,ReplyStatus.MsRoundTripTime]);
  sGauge := strtoint(Format('%s%d',[sTime,ReplyStatus.MsRoundTripTime]));
  LabelPing.caption := inttostr(sGauge)+'ms';

  if sGauge<1000 then
   begin
    GaugePing.MaxValue := 1000;
    GaugePing.ForeColor := clLime;
   end;

  if sGauge>=1000 then
   begin
    GaugePing.MaxValue := 2000;
   end;

  if sGauge>=2000 then
   begin
    GaugePing.MaxValue := 3000;
    GaugePing.ForeColor := $00009CFF;
   end;

  if sGauge>=3000 then
   begin
    GaugePing.MaxValue := 4000;
   end;

  if sGauge>=4000 then
   begin
    GaugePing.MaxValue := 5000;
    GaugePing.ForeColor := clRed;
   end;

  GaugePing.Hint := sHint;
  GaugePing.Progress := sGauge;

end;

procedure TfrmPing.btnPingClick(Sender: TObject);
begin
if btnPing.caption = 'ping'
then
 begin
  TimerPing.Enabled := true;
  btnPing.caption := 'stop';
  mnPing.Caption := 'Stop Ping'
 end
else
 begin
  TimerPing.Enabled := false;
  edtHost.enabled := true;
  btnPing.caption := 'ping';
  mnPing.Caption := 'Start Ping'
 end;
end;

procedure TfrmPing.TimerPingTimer(Sender: TObject);
var
  i: integer;
begin
  ICMP.OnReply := ICMPReply;
  ICMP.ReceiveTimeout := 1000;
  edtHost.Enabled := false; try
    ICMP.Host := edtHost.Text;
      ICMP.Ping;
      Application.ProcessMessages;
  finally end;
end;

procedure TfrmPing.btStopClick(Sender: TObject);
begin
TimerPing.Enabled := false;
edtHost.enabled := true;
end;

procedure TfrmPing.spSkinLinkLabel1DblClick(Sender: TObject);
begin
ShellExecute(Handle,'OPEN','mailto:diabloporc@laposte.net',Nil,Nil,SW_SHOW);
end;

procedure TfrmPing.mnModeReduitClick(Sender: TObject);
begin
frmPing.BorderStyle := bsNone;
frmPing.ClientWidth := 50;
frmPing.ClientHeight := 50;
end;

procedure TfrmPing.mnModePleinClick(Sender: TObject);
begin
frmPing.BorderStyle := bsDialog;
frmPing.ClientWidth := 155;
frmPing.ClientHeight := 50;
end;

procedure TfrmPing.mnQuitterClick(Sender: TObject);
begin
TimerPing.enabled := false;
application.terminate;
end;

procedure TfrmPing.mnPingClick(Sender: TObject);
begin
btnPing.Click;
end;

procedure TfrmPing.TrackBarAlphaChange(Sender: TObject);
begin
frmPing.AlphaBlendValue := TrackBarALpha.Position;
end;

end.