nmicmp.pas

DELPHI里面一些常用的控件

  // Allocate space for remote host info
  GetMem(HostInfo, MAXGETHOSTSTRUCT);

  ICMPHandle := -1; // Nullify the ICMP Handle
  // Constant expression violates subrange bounds

  FTimeOut := 5000; // default timeout to 5 seconds
  FPacketSize := 32; // Default packetsize to 32 bytes

  DLLHandle := -1; // Nullify DLL handle
  // Constant expression violates subrange bounds

  FAborted := false; // Operation not aborted
  @ICMPCreateFile := nil;
  @ICMPCloseHandle := nil;
  @ICMPSendEcho := nil;
  // Allocate window handle and message handling procedure
  // For winsock calls (just looking up host names)
  WinHandle := AllocateHwnd(Self.WndProc);

  // Dynamically load ICMP.DLL
  DLLHandle := LoadLibrary(PChar(con_icmpdll));

  // Setting up ICMP Functions from ICMP.DLL
  if DLLHandle <> -1 then
  begin
    @ICMPCreateFile := GetProcAddress(DLLHandle, con_icmpcreatefile);
    @ICMPCloseHandle := GetProcAddress(DLLHandle, con_icmpclosehandle);
    @ICMPSendEcho := GetProcAddress(DLLHandle, con_icmpsendecho);
  end
  else
    raise EICMPError.Create(con_cantload);
  if (@ICMPCreateFile = nil) or
    (@ICMPCloseHandle = nil) or
    (@ICMPSendEcho = nil) then
    raise EICMPError.Create(con_badimports);
  // Init winsock for getting host names and stuff
  if WSAStartUp($0101, MyWSAData) <> 0 then
    raise EICMPError.Create(con_winserror);

  // Init memory for IPOptions
  GetMem(IPOptions, SizeOf(TIPOptionInfo));

  // Allocate ICMP Handle
  ICMPHandle := ICMPCreateFile;

end;

destructor TNMICMP.Destroy;
begin

  // Free window handle
  DeAllocateHWnd(WinHandle);

  // Free the ICMP handle
  if ICMPHandle <> -1 then
    ICMPCloseHandle(ICMPHandle);

  // Free the DLL library
  if DLLHandle <> -1 then
    FreeLibrary(DLLHandle);

  // cleanup winsock
  WSACleanup;

  // Free memory for IPOptions
  if IPOptions <> nil then
    FreeMem(IPOptions, SizeOf(TIPOptionInfo));

  // Free memory allocated for HostInfo structure
  if HostInfo <> nil then
    FreeMem(HostInfo, MAXGETHOSTSTRUCT);

  // basic TComponent destroy
  inherited Destroy;
end;

procedure TNMICMP.Abort;
begin
  // Set the abort switch to True
  FAborted := true;

  // Call the abort event if it's been set
  if Assigned(FOnStatus) then
    FOnStatus(Self, OPER_ABORT, con_localabort);

  if Assigned(FOnAbort) then
    FOnAbort(Self);
end;


//--------------------------------------------------------------------------//
//----------------------------TNMPing---------------------------------------//
//--------------------------------------------------------------------------//


constructor TNMPing.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPings := 4;
end;

procedure TNMPing.Ping;
var
  Tms, ReplySize: Integer;
  ReqData: Pointer;
  EchoReply: PIPEchoReply;
  ReplyAddress: TInAddr;
begin
  FAborted := false;
  ResolveAddresses;
  if ICMPHandle = -1 then
    raise EICMPError.Create(con_icmperr);
  GetMem(ReqData, FPacketSize);
  ReplySize := SizeOf(TIPEchoReply) + FPacketSize + 16;
  GetMem(EchoReply, ReplySize);
  try
    with IPOptions^ do
    begin
      TTL := 255; // TTL 255 for a ping
      TOS := 0; // Type of Service
      Flags := 0;
      OptionSize := 0;
      OptionData := nil;
    end;
    FillChar(ReqData^, FPacketSize, con_datachar);
    for Tms := 1 to FPings do
    begin
      // Pinging
      // If the operation has been aborted, exit the loop
      Application.ProcessMessages;
      if FAborted then
      begin
        FAborted := false;
        Exit;
      end;
      ICMPSendEcho(ICMPHandle, NetworkAddress, ReqData, FPacketSize, IPOptions, EchoReply, ReplySize, FTimeOut);
      ReplyAddress.s_addr := EchoReply^.Address;
      case EchoReply^.Status of
        ICMP_SUCCESS:
          if Assigned(FOnPing) then
//            If (not FResolveIP) then
            FOnPing(Self, StrPas(inet_ntoa(ReplyAddress)), EchoReply^.DataSize, EchoReply^.RTT);
//            else
//              FOnPing(Self, HostName, EchoReply^.DataSize, EchoReply^.RTT);
        DEST_NET_UNREACHABLE, DEST_HOST_UNREACHABLE:
          if Assigned(FHostUnreachable) then
//            If (not FResolveIP) then
            FHostUnreachable(Self, StrPas(inet_ntoa(ReplyAddress)));
//            else
//              FHostUnreachable(Self, HostName);
        REQ_TIMED_OUT:
          if Assigned(FOnTimeOut) then
            FOnTimeOut(Self);
      end;
      if Assigned(FOnStatus) then
//        If (not FResolveIP) then
        FOnStatus(Self, EchoReply^.Status, StrPas(inet_ntoa(ReplyAddress)));
//        else
//          FOnStatus(Self, EchoReply^.Status, HostName);
    end;
  finally
    if ReqData <> nil then
      FreeMem(ReqData, FPacketSize);
    if EchoReply <> nil then
      FreeMem(EchoReply, ReplySize);
  end;

end;

//--------------------------------------------------------------------------//
//---------------------------TNMTraceRt-------------------------------------//
//--------------------------------------------------------------------------//


constructor TNMTraceRt.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHops := 30;
end;

procedure TNMTraceRt.Trace;
var
  Tmp, Tms, ReplySize: Integer;
  ReqData: Pointer;
  EchoReply: PIPEchoReply;
  ReplyAddress: TInAddr;
  ReplyTime: array[1..3] of Integer;
begin
  FAborted := false;
  TraceDone := false;
  ResolveAddresses;
  if ICMPHandle = -1 then
    raise EICMPError.Create(con_icmperr);
  GetMem(ReqData, FPacketSize);
  FillChar(ReqData^, FPacketSize, con_datachar);
  ReplySize := SizeOf(TIPEchoReply) + FPacketSize + 16;
  GetMem(EchoReply, ReplySize);
  try
    Tms := 0;
    while (Tms <= FHops) and (not FAborted) and (not TraceDone) do
    begin
      Inc(Tms);
      for Tmp := 1 to 3 do
      begin
        with IPOptions^ do
        begin
          TTL := Tms; // TTL 255 for a ping
          TOS := 0; // Type of Service
          Flags := 0;
          OptionSize := 0;
          OptionData := nil;
        end;

        // Send the actual data packet
        ICMPSendEcho(ICMPHandle, NetworkAddress, ReqData, FPacketSize, IPOptions, EchoReply, ReplySize, FTimeOut);
        Application.ProcessMessages;
        if FAborted then
          Break;

        // Put replying address into a TInAddr struct for resolution
        ReplyAddress.s_addr := EchoReply^.Address;

        case EchoReply^.Status of
          // Successful hop
          ICMP_SUCCESS, TTL_EXP_TRANSIT:
            ReplyTime[Tmp] := EchoReply^.RTT;

          // If the packet timed out, set a -1 reply time
          REQ_TIMED_OUT:
            begin
              ReplyTime[Tmp] := -1;
              if Assigned(FOnTimeOut) then
                FOnTimeOut(Self);
            end;
        end;
      //End;
      end;
      if FAborted then
      begin
        Break;
      end;

      case EchoReply^.Status of
        // If it's a successful hop, fire off the event
        ICMP_SUCCESS, TTL_EXP_TRANSIT, REQ_TIMED_OUT:
          if Assigned(FOnHop) then
//            If (not FResolveIP) then
            FOnHop(Self, StrPas(inet_ntoa(ReplyAddress)), ReplyTime[1], ReplyTime[2], ReplyTime[3], Tms);
//            else
//              FOnHop(Self, HostName, ReplyTime[1], ReplyTime[2], ReplyTime[3], Tms);
        DEST_HOST_UNREACHABLE, DEST_NET_UNREACHABLE:
          begin
            if Assigned(FHostUnreachable) then
//            If (not FResolveIP) then
              FHostUnreachable(Self, StrPas(inet_ntoa(ReplyAddress)));
//            else
//              FHostUnreachable(Self, HostName);
            TraceDone := true;
          end;
      end;

      // Fire off status event
      if Assigned(FOnStatus) then
//        If (not FResolveIP) then
        FOnStatus(Self, EchoReply^.Status, StrPas(inet_ntoa(ReplyAddress)));
//        else
//          FOnStatus(Self, EchoReply^.Status, HostName);

      // If the address reached this time is the target, and the echo was successful, the trace is over
      if (EchoReply^.Address = NetworkAddress) and
        (EchoReply^.Status = ICMP_SUCCESS) then
      begin
        if Assigned(FTraceComplete) then
          FTraceComplete(Self);
        TraceDone := true;
      end;
    end;
  finally
    if ReqData <> nil then
      FreeMem(ReqData, FPacketSize);
    if EchoReply <> nil then
      FreeMem(EchoReply, ReplySize);
  end;
end;

end.