Gerar um Ping em Delphi – Rede interna ou Web

Muitas vezes precisamos verificar se um determinado servidor está ativo. A forma mais rápida de fazer isto é dando um ping no servidor. Busquei na internet e não encontrei nada simples e pronto, mas consegui alguns artigos e amostras de código (infelizmene não tenho as fontes aqui agora. Assim que encontrar, darei os devidos créditos) que auxiliaram a chegar nesta solução.

Vamos lá. Declare na uses o seguinte:

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdRawBase, IdRawClient, IdIcmpClient,
  ActiveX, ComObj; // Uses para IdIcmpClient;

Agora, copie e cole na devida unit as funções abaixo.

function TfrmPrincipal.GetStatusCodeStr(statusCode:integer) : string;
begin
  case statusCode of
    0     : Result:='Success';
    11001 : Result:='Buffer Too Small';
    11002 : Result:='Destination Net Unreachable';
    11003 : Result:='Destination Host Unreachable';
    11004 : Result:='Destination Protocol Unreachable';
    11005 : Result:='Destination Port Unreachable';
    11006 : Result:='No Resources';
    11007 : Result:='Bad Option';
    11008 : Result:='Hardware Error';
    11009 : Result:='Packet Too Big';
    11010 : Result:='Request Timed Out';
    11011 : Result:='Bad Request';
    11012 : Result:='Bad Route';
    11013 : Result:='TimeToLive Expired Transit';
    11014 : Result:='TimeToLive Expired Reassembly';
    11015 : Result:='Parameter Problem';
    11016 : Result:='Source Quench';
    11017 : Result:='Option Too Big';
    11018 : Result:='Bad Destination';
    11032 : Result:='Negotiating IPSEC';
    11050 : Result:='General Failure'
    else
    result:='Unknow';
  end;
end;


function  TfrmPrincipal.Ping(const Address:string; Retries,BufferSize:Word): string;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
  i             : Integer;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');

  for i := 0 to Retries-1 do
  begin
    FWbemObjectSet:= FWMIService.ExecQuery(Format('SELECT * FROM Win32_PingStatus where Address=%s AND BufferSize=%d',[QuotedStr(Address),BufferSize]),'WQL',0);
    oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
    if (oEnum.Next(1, FWbemObject, iValue) = 0) then begin

      //--------- Ping com sucesso -------------------------------------------//
      if (FWbemObject.StatusCode=0) then
        result := ''

      //--------- Ping fracassou ---------------------------------------------//
      else begin
        if not VarIsNull(FWbemObject.StatusCode) then
          Result := Format('Reply from %s: %s',[FWbemObject.ProtocolAddress,GetStatusCodeStr(FWbemObject.StatusCode)])
        else
          Result := Format('Reply from %s: %s',[Address,'Error processing request']);
      end;

    end;
  end;
end;

Em algum botão, implemente o seguinte:

procedure TfrmPrincipal.Button1Click(Sender: TObject);
var
  Tentativas, TamBuffer: Word;
  Retorno : string;
begin
  Tentativas := 1;
  TamBuffer  := 32;

  Retorno := Ping(Edit1.Text, Tentativas, TamBuffer);
  if Retorno = '' then
    MessageDlg('Ativo', mtInformation, [mbOK], 0)
  else
    MessageDlg('Inativo. Msg: ' + Retorno, mtError, [mbOK], 0);
end;