Utilizamos cookies propias y de terceros. Al navegar entendemos que aceptas el uso de cookies. +Info.
Política de cookies
Proyecto AjpdSoft

· Inicio
· Buscar
· Contactar
· Cookies
· Descargas
· Foros
· Historia
· Nosotros
· Temas
· Top 10
· Trucos
· Tutoriales
· Usuario
· Wiki

Proyecto AjpdSoft: Foros

AjpdSoft :: Ver tema - Realizar ping a equipos de la red
Foros de discusión Buscar Perfil FAQ Iniciar sesión
Information Realizar ping a equipos de la red

Publicar nuevo tema Responder al tema
Foros de discusión » Borland Delphi, Codegear Delphi .Net   
Ver tema anterior :: Ver tema siguiente
AutorMensaje
varios
Magnífico usuario


Registrado: Oct 10, 2006
Mensajes: 2092

Asunto: Realizar ping a equipos de la red Responder citando

¿Cómo puedo hacer un procedimiento que realice un ping a equipos de la red o de Internet con Delphi 6? he visto el artículo:

http://www.ajpdsoft.com/modules.php?name=Content&pa=showpage&pid=87

Pero indica que no es fiable.

Lo que quiero es añadir la utilidad de ping a una aplicación que estoy desarrollando.
MensajePublicado:
Mie May 05, 2010 7:58 am
Top of PageVer perfil de usuario
alonsojpd
Administrador/Moderador


Registrado: Sep 16, 2003
Mensajes: 2687

Asunto: Re: Realizar ping a equipos de la red Responder citando



Anuncios



varios escribió:
¿Cómo puedo hacer un procedimiento que realice un ping a equipos de la red o de Internet con Delphi 6? he visto el artículo:

http://www.ajpdsoft.com/modules.php?name=Content&pa=showpage&pid=87

Pero indica que no es fiable.

Lo que quiero es añadir la utilidad de ping a una aplicación que estoy desarrollando.


Puedes hacerlo mediante ICMP, utilizando la función del API de Windows "IcmpSendEcho", correspondiente a la librería "icmp.dll".
MensajePublicado:
Mie May 05, 2010 7:59 am
Top of PageVer perfil de usuario
varios
Magnífico usuario


Registrado: Oct 10, 2006
Mensajes: 2092

Asunto: Re: Realizar ping a equipos de la red Responder citando



Anuncios



alonsojpd escribió:
Puedes hacerlo mediante ICMP, utilizando la función del API de Windows "IcmpSendEcho", correspondiente a la librería "icmp.dll".


¿Cómo se haría esto?
MensajePublicado:
Mie May 05, 2010 8:00 am
Top of PageVer perfil de usuario
alonsojpd
Administrador/Moderador


Registrado: Sep 16, 2003
Mensajes: 2687

Asunto: Re: Realizar ping a equipos de la red Responder citando



Anuncios



varios escribió:
¿Cómo se haría esto?


Sería algo así:

En una unidad a parte, llamada por ejemplo "aping" puedes poner el siguiente código:

Código:

unit aping;

interface
uses
  Windows, SysUtils, Classes;

type
  TSunB = packed record
    s_b1, s_b2, s_b3, s_b4: byte;
  end;

  TSunW = packed record
    s_w1, s_w2: word;
  end;

  PIPAddr = ^TIPAddr;
  TIPAddr = record
    case integer of
      0: (S_un_b: TSunB);
      1: (S_un_w: TSunW);
      2: (S_addr: longword);
  end;

IPAddr = TIPAddr;

function IcmpCreateFile : THandle; stdcall; external 'icmp.dll';
function IcmpCloseHandle (icmpHandle : THandle) : boolean;
    stdcall; external 'icmp.dll'
function IcmpSendEcho (
    IcmpHandle : THandle; DestinationAddress : IPAddr;
    RequestData : Pointer; RequestSize : Smallint;
    RequestOptions : pointer;
    ReplyBuffer : Pointer;
    ReplySize : DWORD;
    Timeout : DWORD) : DWORD; stdcall; external 'icmp.dll';


function Ping(InetAddress : string) : boolean;

procedure TranslateStringToTInAddr(AIP: string; var AInAddr);

implementation

uses
  WinSock;

function Fetch(var AInput: string; const ADelim: string = ' ';
    const ADelete: Boolean = true) : string;
var
  iPos: Integer;
begin
  if ADelim = #0 then begin
    // AnsiPos does not work with #0
    iPos := Pos(ADelim, AInput);
  end else begin
    iPos := Pos(ADelim, AInput);
  end;
  if iPos = 0 then begin
    Result := AInput;
    if ADelete then begin
      AInput := '';
    end;
  end else begin
    result := Copy(AInput, 1, iPos - 1);
    if ADelete then begin
      Delete(AInput, 1, iPos + Length(ADelim) - 1);
    end;
  end;
end;

procedure TranslateStringToTInAddr(AIP: string; var AInAddr);
var
  phe: PHostEnt;
  pac: PChar;
  GInitData: TWSAData;
begin
  WSAStartup($101, GInitData);
  try
    phe := GetHostByName(PChar(AIP));
    if Assigned(phe) then
    begin
      pac := phe^.h_addr_list^;
      if Assigned(pac) then
      begin
        with TIPAddr(AInAddr).S_un_b do begin
          s_b1 := Byte(pac[0]);
          s_b2 := Byte(pac[1]);
          s_b3 := Byte(pac[2]);
          s_b4 := Byte(pac[3]);
        end;
      end
      else
      begin
        raise Exception.Create('Error al obtener la IP del equipo');
      end;
    end
    else
    begin
      raise Exception.Create('Error al obtener el nombre de red');
    end;
  except
    FillChar(AInAddr, SizeOf(AInAddr), #0);
  end;
  WSACleanup;
end;

function Ping(InetAddress : string) : boolean;
var
Handle : THandle;
InAddr : IPAddr;
DW : DWORD;
rep : array[1..128] of byte;
begin
  result := false;
  Handle := IcmpCreateFile;
  if Handle = INVALID_HANDLE_VALUE then
   Exit;
  TranslateStringToTInAddr(InetAddress, InAddr);
  DW := IcmpSendEcho(Handle, InAddr, nil, 0, nil, @rep, 128, 0);
  Result := (DW <> 0);
  IcmpCloseHandle(Handle);
end;

end.



El código del formulario sería algo así:

Código:

unit UnidadMenuPrincipal;

{$R WinXP.res}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,
  Graphics, Controls, Forms,
  Dialogs, StdCtrls, aping, ComCtrls,
  shellapi, Buttons, ThemeMgr, inifiles;

type
  TformMenuPrincipal = class(TForm)
    txtResultado: TMemo;
    LWEB: TLabel;
    bGuardar: TBitBtn;
    ThemeManager1: TThemeManager;
    dlGuardar: TSaveDialog;
    bSalir: TBitBtn;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    txtIP: TComboBox;
    txtBytes: TEdit;
    txtTiempo: TEdit;
    txtNumRepeticiones: TEdit;
    Label4: TLabel;
    btPing: TBitBtn;
    opLimpiar: TCheckBox;
    procedure btPingClick(Sender: TObject);
    procedure txtIPKeyPress(Sender: TObject; var Key: Char);
    procedure LWEBClick(Sender: TObject);
    procedure bGuardarClick(Sender: TObject);
    procedure bSalirClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  ip_option_information = record
    Ttl : byte;
    Tos : byte;
    Flags : byte;
    OptionsSize : byte;
    OptionsData : pointer;
  end;

  ICMP_ECHO_REPLY = record
    Address : IPAddr;
    Status : ULONG;
    RoundTripTime : ULONG;
    DataSize : Word;
    Reserved : Word;
    Data : Pointer;
    Options : IP_OPTION_INFORMATION;
   end;

var
formMenuPrincipal: TformMenuPrincipal;

implementation

{$R *.dfm}

function buscarElementoComboBox (
    combo : TComboBox; elemento : string) : boolean;
var
  i : integer;
begin
  Result := false;
  for i := 0 to combo.Items.Count - 1 do
  begin
    if AnsiUpperCase(combo.Items[i]) = AnsiUpperCase(elemento) then
    begin
      Result := true;
      Exit;
    end;
  end;
end;

//lee un valor booleano de un fichero INI
function leBoolINI (clave, cadena : string; defecto : boolean) : boolean;
begin
  with tinifile.create (changefileext(paramstr(0),'.INI')) do
  try
    result := readbool (clave, cadena, defecto);
  finally
    free;
  end;
end;

//lee un valor numérico de un fichero INI
function leNumINI (clave, cadena : string; defecto : Integer) : Integer;
begin
  with tinifile.create (changefileext(paramstr(0),'.INI')) do
  try
    result := ReadInteger (clave, cadena, defecto);
  finally
    free;
  end;
end;

//lee un valor string de un fichero INI
function leCadINI (clave, cadena : string; defecto : String) : String;
begin
  with tinifile.create (changefileext(paramstr(0),'.INI')) do
  try
    result := ReadString (clave, cadena, defecto);
  finally
    free;
  end;
end;

//escribe un valor string en un fichero INI
procedure esCadINI (clave, cadena : string; valor : String);
begin
  with tinifile.create (changefileext(paramstr(0),'.INI')) do
  try
    WriteString (clave, cadena, valor);
  finally
    free;
  end;
end;

//escribe un valor boolean en un fichero INI
procedure esBoolINI (clave, cadena : string; valor : Boolean);
begin
  with tinifile.create (changefileext(paramstr(0),'.INI')) do
  try
    WriteBool (clave, cadena, valor);
  finally
    free;
  end;
end;

procedure TformMenuPrincipal.btPingClick(Sender: TObject);
var
  Handle : THandle;
  InAddr : IPAddr;
  DW : DWORD;
  cnt : integer;
  SAddr : string;
  pnum : integer;
  minTime : longint;
  maxTime : longint;
  allTime : longint;
  stat : longint;
  PingBuf : array[0..31] of char;
  Reply : ICMP_ECHO_REPLY;
begin
  if opLimpiar.Checked then
  begin
    txtResultado.Clear;
    Refresh;
  end;

  if txtResultado.Text <> '' then
  begin
    txtResultado.Lines.Add('');
    txtResultado.Lines.Add('');
  end;

  if ping(txtIP.Text) then
  begin
    txtResultado.Lines.Add (DateTimeToStr(Now) + ' ' +
        'Realizando ping a ' + txtIP.Text + ' [OK]');
    if not buscarElementoComboBox(txtIP, txtIP.Text) then
      txtIP.Items.Add (txtIP.Text);
    txtIP.Items.SaveToFile(
        IncludeTrailingPathDelimiter (ExtractFilePath(Application.ExeName)) +
        'equipos.txt');
  end
  else
    txtResultado.Lines.Add (DateTimeToStr(Now) +
        ' Realizando ping a ' + txtIP.Text + ' [NO DISPONIBLE]');

  Handle := IcmpCreateFile;
  if Handle = INVALID_HANDLE_VALUE then
    Halt(2);
  TranslateStringToTInAddr(txtIP.Text, InAddr);

  SAddr := Format('%d.%d.%d.%d',[InAddr.S_un_b.s_b1, InAddr.S_un_b.s_b2,
      InAddr.S_un_b.s_b3, InAddr.S_un_b.s_b4]);

  txtResultado.Lines.Add (DateTimeToStr(Now) +
      Format (' Realizando ping %s [%s]',[txtIP.Text, SAddr]) );

  pnum := 0;
  minTime := MaxInt -1;
  maxTime := 0;
  AllTime := 0;

  Reply.Data := @pingBuf;
  Reply.DataSize := 32;

  for cnt := 1 to StrToInt(txtNumRepeticiones.Text) do
  begin
    DW := IcmpSendEcho(Handle, InAddr, @PingBuf, strtoint(txtBytes.text), nil, @reply,
        SizeOf(icmp_echo_reply) + strtoint(txtBytes.text), 3000);
    if DW = 0 then
       txtResultado.Lines.Add (DateTimeToStr(Now) +
           ' Tiempo de espera agotado')
    else
    begin
      txtResultado.Lines.Add (DateTimeToStr(Now) +
          (Format(' Respuesta desde %s: bytes = ' +
          txtBytes.Text + ' tiempo=%dms TTL=%d',
          [SAddr, Reply.RoundTripTime, Reply.Options.Ttl])));
      stat := Reply.RoundTripTime;
      inc(pnum);
      if minTime > stat then
        minTime := stat;
      if maxTime < stat then
        maxTime := stat;
      AllTime := AllTime + stat;
    end;
    Sleep(StrToInt(txtTiempo.Text));
  end;
  IcmpCloseHandle(Handle);

  txtResultado.Lines.Add (' Estadísticas de ping para ' + SAddr + ':');
  txtResultado.Lines.Add ('  Paquetes: ');
  txtResultado.Lines.Add ('     + Enviados  =  ' + txtNumRepeticiones.Text);
  txtResultado.Lines.Add ('     + Recibidos = ' + inttostr(pnum));
  txtResultado.Lines.Add ('     + Perdidos  = ' +
      inttostr(strtoint(txtNumRepeticiones.Text) - pnum));
  if StrToInt(txtNumRepeticiones.Text) = pnum then
  begin
    txtResultado.Lines.Add ('  Tiempos aproximados de envío y recepción:');
    txtResultado.Lines.Add ('     + Mínimo = ' +  inttostr(minTime) + ' ms');
    txtResultado.Lines.Add ('     + Máximo = ' + inttostr(maxTime) + ' ms');
    txtResultado.Lines.Add ('     + Media  = ' + inttostr(round(AllTime / pnum)) + 'ms');
  end;
end;

procedure TformMenuPrincipal.txtIPKeyPress(
    Sender: TObject; var Key: Char);
begin
  if key = #13 then
    btPingClick(Self);
end;

procedure TformMenuPrincipal.LWEBClick(Sender: TObject);
begin
  ShellExecute(Handle, Nil, PChar('http://www.ajpdsoft.com'),
      Nil, Nil, SW_SHOWNORMAL);
end;

procedure TformMenuPrincipal.bGuardarClick(Sender: TObject);
begin
  if dlGuardar.Execute then
    txtResultado.Lines.SaveToFile(dlGuardar.FileName);
end;

procedure TformMenuPrincipal.bSalirClick(Sender: TObject);
begin
  close;
end;

procedure TformMenuPrincipal.FormShow(Sender: TObject);
begin
  if ParamStr(1) <> '' then
  begin
    txtIP.Text := ParamStr(1);
    btPing.SetFocus;
  end;
end;

procedure TformMenuPrincipal.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  esCadINI('Datos', 'Equipo', txtIP.Text);
  esCadINI('Datos', 'Bytes', txtBytes.Text);
  esCadINI('Datos', 'Tiempo', txtTiempo.Text);
  esCadINI('Datos', 'Número paquetes', txtNumRepeticiones.Text);
  esBoolINI('Datos', 'Limpiar datos actuales', opLimpiar.Checked);
end;

procedure TformMenuPrincipal.FormCreate(Sender: TObject);
var
  fichero : string;
begin
  txtIP.Text := leCadINI('Datos', 'Equipo', 'localhost');
  txtBytes.Text := leCadINI('Datos', 'Bytes', '32');
  txtTiempo.Text := leCadINI('Datos', 'Tiempo', '1000');
  txtNumRepeticiones.Text := leCadINI('Datos', 'Número paquetes', '5');
  opLimpiar.Checked := leBoolINI('Datos', 'Limpiar datos actuales', false);
  fichero := IncludeTrailingPathDelimiter (
      ExtractFilePath(Application.ExeName)) + 'equipos.txt';
  if FileExists(fichero) then
    txtIP.Items.LoadFromFile(fichero);
end;

end.



El formulario tiene estos componentes:
MensajePublicado:
Mie May 05, 2010 8:03 am
Top of PageVer perfil de usuario
Mostrar mensajes de anteriores:   
Todas las horas son GMT - 1 Horas
Publicar nuevo tema Responder al tema
Foros de discusión » Borland Delphi, Codegear Delphi .Net  

Cambiar a:  
Key
  Puede publicar nuevos temas en este foro
No puede responder a temas en este foro
No puede editar sus mensajes en este foro
No puede borrar sus mensajes en este foro
No puede votar en encuestas en este foro
Este sitio web NO CONTIENE malware, todos los programas con código fuente aquí. Autor: Alonso Javier Pérez Díaz Google+ Síguenos en Google+