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
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.