end;
  pPtr := PaPInAddr(phe^.h_addr_list);
  I := 0;
  while (pPtr^[I] <> nil) and (i<20) do
   begin
    FActiveIP[I]:=inet_ntoa(pptr^[I]^);
    Inc(I);
   end;
  setlength(FActiveIP,i);
end;

procedure Tcap_ip.set_socket_state;
var
  i,iErrorCode:integer;
  sa: tSockAddrIn;
  dwBufferLen:array[0..10]of DWORD;
  dwBufferInLen:DWORD;
  dwBytesReturned:DWORD;
begin
   if high(FActiveIP)=-1 then exit;
   setlength(Fsocket,high(FActiveIP)+1);
   for i:=0 to high(FActiveIP) do
     begin
       Fsocket[i]:= socket(AF_INET , SOCK_RAW , IPPROTO_IP);
       sa.sin_family:= AF_INET;
       sa.sin_port := htons(i);
       sa.sin_addr.S_addr:=Inet_addr(pchar(FActiveIP[i]));
       iErrorCode := bind(Fsocket[i],sa, sizeof(sa));
       CheckSockError(iErrorCode);

       dwBufferInLen := 1 ;
       dwBytesReturned:=0;
 //設置Fsocket為SIO_RCVALL接收所有的IP包
       iErrorCode:=FWSAIoctl(Fsocket[i], SIO_RCVALL,@dwBufferInLen, sizeof(dwBufferInLen),
                        @dwBufferLen, sizeof(dwBufferLen),@dwBytesReturned ,nil ,nil);

	CheckSockError(iErrorCode);
        iErrorCode:=WSAAsyncSelect(Fsocket[i],FWindowHandle,WM_CapIp+i,FD_READ or FD_CLOSE);
	CheckSockError(iErrorCode);
     end;
end;

//讀IP數據
procedure Tcap_ip.cap_ip(socket_no:integer);
var
  iErrorCode:integer;
  RecvBuf:array[0..MAX_PACK_LEN] of char;
begin
     fillchar(RecvBuf,sizeof(RecvBuf),0);
     iErrorCode := frecv(Fsocket[socket_no], RecvBuf, sizeof(RecvBuf), 0);
     CheckSockError(iErrorCode);
    if not Fpause then
     begin
     iErrorCode := DecodeIpPack(FActiveIP[socket_no],RecvBuf, iErrorCode);
     CheckSockError(iErrorCode);
     end;
end;

//協議識別程序
function Tcap_ip.CheckProtocol(iProtocol:integer):string;
var
 i:integer;
begin
  result:='';
   case iProtocol of
     IPPROTO_IP   :result:='IP';
     IPPROTO_ICMP :result:='ICMP';
     IPPROTO_IGMP :result:='IGMP';
     IPPROTO_GGP  :result:='GGP';
     IPPROTO_TCP  :result:='TCP';
     IPPROTO_PUP  :result:='PUP';
     IPPROTO_UDP  :result:='UDP';
     IPPROTO_IDP  :result:='IDP';
     IPPROTO_ND   :result:='NP';
     IPPROTO_RAW  :result:='RAW';
     IPPROTO_MAX  :result:='MAX';
    else          result:='';
   end;
end;


//IP解包程序
function Tcap_ip.DecodeIpPack(ip:string;buf:pchar;iBufSize:integer):integer;
var
  SourcePort,DestPort:word;
  iProtocol, iTTL:integer;
  szProtocol :array[0..MAX_PROTO_TEXT_LEN] of char;
  szSourceIP :array[0..MAX_ADDR_LEN] of char;
  szDestIP   :array[0..MAX_ADDR_LEN] of char;

  pIpheader:IP_HEADER;
  pTcpHeader:TCP_HEADER;
  pUdpHeader:UDP_HEADER;
  pIcmpHeader:ICMP_HEADER;
  saSource, saDest:TSockAddrIn;
  iIphLen,data_size:integer;
  TcpHeaderLen:integer;
  TcpData:pchar;
begin
        result:=0;
        CopyMemory(@pIpheader,buf,sizeof(pIpheader));
//協議甄別
	iProtocol := pIpheader.proto;
	StrLCopy(szProtocol, pchar(CheckProtocol(iProtocol)),15);

//源地址
	saSource.sin_addr.s_addr := pIpheader.sourceIP;
	strlcopy(szSourceIP, inet_ntoa(saSource.sin_addr), MAX_ADDR_LEN);
//目的地址
	saDest.sin_addr.s_addr := pIpheader.destIP;
	strLcopy(szDestIP, inet_ntoa(saDest.sin_addr), MAX_ADDR_LEN);
	iTTL := pIpheader.ttl;
//計算IP首部的長度
	iIphLen :=sizeof(pIpheader);
//根據協議類型分別調用相應的函數
	case iProtocol of
           IPPROTO_TCP	:begin
                          CopyMemory(@pTcpHeader,buf+iIphLen,sizeof(pTcpHeader));
                          SourcePort := ntohs(pTcpHeader.TCP_Sport);//源端口
                          DestPort := ntohs(pTcpHeader.TCP_Dport);  //目的端口
                          TcpData:=buf+iIphLen+sizeof(pTcpHeader);
                          data_size:=iBufSize-iIphLen-sizeof(pTcpHeader);
                         end;
	   IPPROTO_UDP	:begin
                          CopyMemory(@pUdpHeader,buf+iIphLen,sizeof(pUdpHeader));
                          SourcePort := ntohs(pUdpHeader.uh_sport);//源端口
                          DestPort := ntohs(pUdpHeader.uh_dport);  //目的端口
                          TcpData:=buf+iIphLen+sizeof(pUdpHeader);
                          data_size:=iBufSize-iIphLen-sizeof(pUdpHeader);
                         end;
	   IPPROTO_ICMP	:begin
                          CopyMemory(@pIcmpHeader,buf+iIphLen,sizeof(pIcmpHeader));
                          SourcePort := pIcmpHeader.i_type;//類型
                          DestPort := pIcmpHeader.i_code;  //代碼
                          TcpData:=buf+iIphLen+sizeof(pIcmpHeader);
                          data_size:=iBufSize-iIphLen-sizeof(pIcmpHeader);
                         end;
	   else begin
                    SourcePort :=0;
                    DestPort := 0;  //代碼
                    TcpData:=buf+iIphLen;
                    data_size:=iBufSize-iIphLen;
                end;
	end;

  if Assigned(FOnCap) then
   FOnCap(ip,szProtocol,szSourceIP,szDestIP,inttostr(SourcePort),inttostr(DestPort)
          ,buf,iBufSize-data_size,TcpData,data_size);
end;

//SOCK錯誤處理程序
function Tcap_ip.CheckSockError(iErrorCode:integer):boolean;	//出錯處理函數
begin
    if(iErrorCode=SOCKET_ERROR) then
     begin
       if Assigned(FOnError) then FOnError(inttostr(GetLastError)+SysErrorMessage(GetLastError));
       result:=true;
     end else result:=false;
end;

procedure Tcap_ip.WndProc(var MsgRec: TMessage);
begin
    with MsgRec do
     if (Msg >=WM_CapIp) and (Msg <= WM_CapIp+high(FActiveIP)) then
         cap_ip(msg-WM_CapIp)
       else
       Result := DefWindowProc(Handle, Msg, wParam, lParam);

end;

constructor Tcap_ip.Create(Owner : TComponent);
begin
    Inherited Create(Owner);
    Fpause:=false;
    Finitsocket:=false;
    setlength(Fsocket,0);

    FWindowHandle := XSocketAllocateHWnd(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor Tcap_ip.Destroy;
var i:integer;
begin
   for i:=0 to high(Fsocket) do FCloseSocket(Fsocket[i]);
   if self.Finitsocket then
     begin
       FWSACleanup;
      if Fhand_dll <> 0 then FreeLibrary(Fhand_dll);
     end; 
    inherited Destroy;
end;

function  Tcap_ip.init_socket:boolean;//初始化
var
 GInitData:TWSAData;
begin
    result:=true;
    IF Finitsocket then exit;
    Fhand_dll := LoadLibrary('ws2_32.dll');
    if Fhand_dll = 0 then
      begin
        raise ESocketException.Create('Unable to register ws2_32.dll');
        result:=false;
        exit;
      end;
    @FWSAStartup  := GetProcAddress(Fhand_dll, 'WSAStartup');

    @FOpenSocket :=  GetProcAddress(Fhand_dll, 'socket');
    @FInet_addr :=   GetProcAddress(Fhand_dll, 'inet_addr');
    @Fhtons  :=      GetProcAddress(Fhand_dll, 'htons');
    @FConnect :=     GetProcAddress(Fhand_dll, 'connect');
    @FCloseSocket := GetProcAddress(Fhand_dll, 'closesocket');
    @Fsend        := GetProcAddress(Fhand_dll, 'send');
    @FWSAIoctl := GetProcAddress(Fhand_dll, 'WSAIoctl');
    @Frecv        := GetProcAddress(Fhand_dll, 'recv');
    @FWSACleanup  := GetProcAddress(Fhand_dll, 'WSACleanup');
    @FWSAAsyncSelect:=GetProcAddress(Fhand_dll, 'WSAAsyncSelect');
    if (@FWSAStartup =nil) or(@Fhtons =nil) or (@FConnect =nil) or (@Fsend =nil) or (@FWSACleanup=nil) or
       (@FOpenSocket =nil) or (@FInet_addr =nil)or (@FCloseSocket =nil) or (@recv=nil)or (@FWSAIoctl=nil)
       or (@FWSAAsyncSelect=nil) then
         begin
          raise ESocketException.Create('加載dll函數錯誤!');
          result:=false;
          exit;
         end;

   if FWSAStartup($201,GInitData)<>0 then
     begin
      raise ESocketException.Create('初始化SOCKET2函數失敗!');
      result:=false;
      exit;
     end;
  Finitsocket:=true;
end;
procedure  Tcap_ip.StartCap;
begin
 if not Finitsocket then
    if not init_socket then exit;
   get_ActiveIP;
   set_socket_state;
end;
procedure  Tcap_ip.pause;
begin
  if Finitsocket and (high(Fsocket)>-1) then
    Fpause:=not Fpause;
end;

procedure  Tcap_ip.StopCap;
var i:integer;
begin
   for i:=0 to high(Fsocket) do FCloseSocket(Fsocket[i]);
end;

procedure Register;
begin
    RegisterComponents('Standard', [Tcap_ip]);
end;

end.