Lance un ping et le recupere dans une fenetre style flashget

Soyez le premier à donner votre avis sur cette source.

Vue 8 690 fois - Téléchargée 1 109 fois

Description

hello

je suis en 56k alors je ping souvent un server pour voir si je lag ou pas :) c'est un laggometre lol
voila c tout

Source / Exemple :


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.

Conclusion :


si vous avez fait une modif, mailez les moi merci :)
idem pour les bugs

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

JulioDelphi
Messages postés
2349
Date d'inscription
dimanche 5 octobre 2003
Statut
Modérateur
Dernière intervention
18 novembre 2010
12 -
@hurrycane : au 21/10/2003 (date de la source) : oui, la campagne n'est pas encore totalement désservie.
@facilus : comment ? si le ping est > 2000, tu peux le considérer mort je pense ^^
cs_facilus
Messages postés
33
Date d'inscription
lundi 19 juin 2006
Statut
Membre
Dernière intervention
15 novembre 2007
-
cmt savoir si un sereveur repond ou pa de ton code ?
hurrycane
Messages postés
123
Date d'inscription
samedi 4 janvier 2003
Statut
Membre
Dernière intervention
19 juin 2009
1 -
t'est encore au 56 k
JulioDelphi
Messages postés
2349
Date d'inscription
dimanche 5 octobre 2003
Statut
Modérateur
Dernière intervention
18 novembre 2010
12 -
xtrack
Messages postés
10
Date d'inscription
vendredi 11 avril 2003
Statut
Membre
Dernière intervention
4 juillet 2004
-
oui surtout que SkinCtrls nous on l'a pas

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.