unit CapIp; interface uses Windows, Messages,Classes,winsock,sysutils; const WM_CapIp = WM_USER + 200; STATUS_FAILED =$FFFF; //定义异常出错代码 MAX_PACK_LEN =65535; //接收的最大IP报文 MAX_ADDR_LEN =16; //点分十进制地址的最大长度 MAX_PROTO_TEXT_LEN =16; //子协议名称(如"TCP")最大长度 MAX_PROTO_NUM =12; //子协议数量 MAX_HOSTNAME_LAN =255; //最大主机名长度 CMD_PARAM_HELP =true; IOC_IN =$80000000; IOC_VENDOR =$18000000; IOC_out =$40000000; SIO_RCVALL =IOC_IN or IOC_VENDOR or 1;// or IOC_out; SIO_RCVALL_MCAST =IOC_IN or IOC_VENDOR or 2; SIO_RCVALL_IGMPMCAST =IOC_IN or IOC_VENDOR or 3; SIO_KEEPALIVE_VALS =IOC_IN or IOC_VENDOR or 4; SIO_ABSORB_RTRALERT =IOC_IN or IOC_VENDOR or 5; SIO_UCAST_IF =IOC_IN or IOC_VENDOR or 6; SIO_LIMIT_BROADCASTS =IOC_IN or IOC_VENDOR or 7; SIO_INDEX_BIND =IOC_IN or IOC_VENDOR or 8; SIO_INDEX_MCASTIF =IOC_IN or IOC_VENDOR or 9; SIO_INDEX_ADD_MCAST =IOC_IN or IOC_VENDOR or 10; SIO_INDEX_DEL_MCAST =IOC_IN or IOC_VENDOR or 11; type tcp_keepalive=record onoff:Longword; keepalivetime:Longword; keepaliveinterval:Longword; end; // New WSAIoctl Options //IP头 type _iphdr=record h_lenver :byte; //4位首部长度+4位IP版本号 tos :char; //8位服务类型TOS total_len :char; //16位总长度（字节） ident :word; //16位标识 frag_and_flags :word; //3位标志位 ttl :byte; //8位生存时间 TTL proto :byte; //8位协议 (TCP, UDP 或其他) checksum :word; //16位IP首部校验和 sourceIP :Longword; //32位源IP地址 destIP :Longword; //32位目的IP地址 end; IP_HEADER=_iphdr; type _tcphdr=record //定义TCP首部 TCP_Sport :word; //16位源端口 TCP_Dport :word; //16位目的端口 th_seq :longword; //32位序列号 th_ack :longword; //32位确认号 th_lenres :byte; //4位首部长度/6位保留字 th_flag :char; //6位标志位 th_win :word; //16位窗口大小 th_sum :word; //16位校验和 th_urp :word; //16位紧急数据偏移量 end; TCP_HEADER=_tcphdr; type _udphdr=record //定义UDP首部 uh_sport :word; //16位源端口 uh_dport :word; //16位目的端口 uh_len :word; //16位长度 uh_sum :word; //16位校验和 end; UDP_HEADER=_udphdr; type _icmphdr=record //定义ICMP首部 i_type :byte; //8位类型 i_code :byte; //8位代码 i_cksum :word; //16位校验和 i_id :word; //识别号（一般用进程号作为识别号） // i_seq :word; //报文序列号 timestamp :word; //时间戳 end; ICMP_HEADER=_icmphdr; type _protomap=record //定义子协议映射表 ProtoNum :integer; ProtoText :array[0..MAX_PROTO_TEXT_LEN] of char; end; TPROTOMAP=_protomap; type ESocketException = class(Exception); TWSAStartup = function (wVersionRequired: word; var WSData: TWSAData): Integer; stdcall; TOpenSocket = function (af, Struct, protocol: Integer): TSocket; stdcall; TInet_addr = function (cp: PChar): u_long; stdcall; Thtons = function (hostshort: u_short): u_short; stdcall; TConnect = function (s: TSocket; var name: TSockAddr; namelen: Integer): Integer; stdcall; TWSAIoctl = function (s: TSocket; cmd: DWORD;lpInBuffer: PCHAR; dwInBufferLen:DWORD;lpOutBuffer: PCHAR; dwOutBufferLen: DWORD; lpdwOutBytesReturned: LPDWORD;lpOverLapped: POINTER; lpOverLappedRoutine: POINTER): Integer; stdcall; TCloseSocket = function (s: TSocket): Integer; stdcall; Tsend = function( s:TSOCKET; buf:pchar;Len:integer;flags:integer):Integer;stdcall; Trecv = function( s:TSOCKET; var buf;Len:integer;flags:integer):Integer;stdcall; TWSAAsyncSelect =function (s: TSocket; HWindow: HWND; wMsg: u_int; lEvent: Longint): Integer; stdcall; TWSACleanup =function():integer;stdcall; //TOnCap = procedure(ip,proto,sourceIP,destIP,SourcePort,DestPort: string; // header:pchar;header_size:integer;data:pchar;data_size:integer) of object; //TOnCap = procedure(dateStr,timeStr,protoType,PaKnum,direct,proto,Flag, // remoteIP,DestPort,data_size: string) of object; TOnCap = procedure(Allinfo:string) of object; TOnError = procedure(Error : string) of object; TCapIp = class private Fhand_dll :HModule; // Handle for mpr.dll FWindowHandle : HWND; FOnCap :TOnCap; //捕捉数据的事件 FOnError :TOnError; //发生错误的事件 Fsocket :array of Tsocket; FActiveIP :array of string; //存放可用的IP FWSAStartup : TWSAStartup; FOpenSocket : TOpenSocket; FInet_addr : TInet_addr; Fhtons : Thtons; FConnect : TConnect; FCloseSocket : TCloseSocket; Fsend :Tsend; FWSAIoctl :TWSAIoctl; Frecv :Trecv; FWSACleanup :TWSACleanup; FWSAAsyncSelect :TWSAAsyncSelect; direct,proto,Flag,remoteIP,DestPort,data_size:string; localIp:string; protected procedure WndProc(var MsgRec: TMessage); //IP解包函数 function DecodeIpPack(ip:string;buf:pchar;iBufSize:integer):integer; //TCP解包函数 //function DecodeTcpPack(TcpBuf:pchar;iBufSize:integer):integer; //UDP解包函数 //function DecodeUdpPack(p:pchar;i:integer):integer; //ICMP解包函数 //function DecodeIcmpPack(p:pchar;i:integer):integer; //协议检查 function CheckProtocol(iProtocol:integer):string; procedure CapIp(socket_no:integer); //得当前的IP列表 procedure get_ActiveIP; //设置网卡状态 procedure set_socket_state; //出错处理函数 function CheckSockError(iErrorCode:integer):boolean; public Fpause :boolean;//暂停 Finitsocket :boolean;//是否已初始化 constructor Create(); destructor Destroy; override; function init_socket:boolean;//初始化 procedure StartCap;//开始捕捉 procedure pause; //暂停 procedure StopCap;//结束捕捉 property Handle : HWND read FWindowHandle; published property OnCap : TOnCap read FOnCap write FOnCap; property OnError : TOnError read FOnError write FOnError; end; implementation function XSocketWindowProc(ahWnd : HWND;auMsg : Integer;awParam : WPARAM; alParam : LPARAM): Integer; stdcall; var Obj : TCapIp; MsgRec : TMessage; begin { At window creation ask windows to store a pointer to our object } {GetWindowLong:his function returns the 32 bit value at the specified } {offset into the extra window memory for the specified window. } Obj := TCapIp(GetWindowLong(ahWnd, 0)); { If the pointer is not assigned, just call the default procedure } { DefWindowProc: This function ensures that all incoming Windows messages are processed. } if not Assigned(Obj) then Result := DefWindowProc(ahWnd, auMsg, awParam, alParam) else begin { Delphi use a TMessage type to pass paramter to his own kind of } { windows procedure. So we are doing the same... } MsgRec.Msg := auMsg; MsgRec.wParam := awParam; MsgRec.lParam := alParam; Obj.WndProc(MsgRec); Result := MsgRec.Result; end; end; var XSocketWindowClass: TWndClass = ( style : 0; lpfnWndProc : @XSocketWindowProc; cbClsExtra : 0; cbWndExtra : SizeOf(Pointer); hInstance : 0; hIcon : 0; hCursor : 0; hbrBackground : 0; lpszMenuName : nil; lpszClassName : 'TCapIp'); function XSocketAllocateHWnd(Obj : TObject): HWND; var TempClass : TWndClass; ClassRegistered : Boolean; begin { Check if the window class is already registered } XSocketWindowClass.hInstance := HInstance; ClassRegistered := GetClassInfo(HInstance, XSocketWindowClass.lpszClassName, TempClass); if not ClassRegistered then begin { Not yet registered, do it right now } Result := Windows.RegisterClass(XSocketWindowClass); if Result = 0 then Exit; end; { Now create a new window } Result := CreateWindowEx(WS_EX_TOOLWINDOW, XSocketWindowClass.lpszClassName, '', { Window name } WS_POPUP, { Window Style } 0, 0, { X, Y } 0, 0, { Width, Height } 0, { hWndParent } 0, { hMenu } HInstance, { hInstance } nil); { CreateParam } { if successfull, the ask windows to store the object reference } { into the reserved byte (see RegisterClass) } if (Result <> 0) and Assigned(Obj) then SetWindowLong(Result, 0, Integer(Obj)); end; procedure XSocketDeallocateHWnd(Wnd: HWND); begin DestroyWindow(Wnd); end; procedure TCapIp.get_ActiveIP; type TaPInAddr = Array[0..20] of PInAddr; PaPInAddr = ^TaPInAddr; var phe: PHostEnt; pptr: PaPInAddr; Buffer: Array[0..63] of Char; I: Integer; begin setlength(FActiveIP,20); GetHostName(Buffer, SizeOf(Buffer)); phe := GetHostByName(buffer); if phe = nil then begin setlength(FActiveIP,0); if Assigned(FOnError) then FOnError('没有找到可绑定的IP!'); exit; 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); localIp:=FActiveIP[i-1]; end; procedure TCapIp.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; //receive all packages ! 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; procedure TCapIp.CapIp(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); data_size:=inttostr(iErrorCode); if not Fpause then begin iErrorCode := DecodeIpPack(FActiveIP[socket_no],RecvBuf, iErrorCode); CheckSockError(iErrorCode); end; end; function TCapIp.CheckProtocol(iProtocol:integer):string; 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; function TCapIp.DecodeIpPack(ip:string;buf:pchar;iBufSize:integer):integer; var // LSourcePort,LDestPort:word; LDestPort: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:integer; // TcpHeaderLen:integer; // TcpData:pchar; AllInfo:string; 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; Flag:='0'; iIphLen :=sizeof(pIpheader); case iProtocol of IPPROTO_TCP : begin CopyMemory(@pTcpHeader,buf+iIphLen,sizeof(pTcpHeader)); //LSourcePort := ntohs(pTcpHeader.TCP_Sport); LDestPort := ntohs(pTcpHeader.TCP_Dport); //TcpData:=buf+iIphLen+sizeof(pTcpHeader); //data_size:=iBufSize-iIphLen-sizeof(pTcpHeader); flag:='1'; end; IPPROTO_UDP : begin CopyMemory(@pUdpHeader,buf+iIphLen,sizeof(pUdpHeader)); //LSourcePort := ntohs(pUdpHeader.uh_sport); LDestPort := 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)); //LSourcePort := pIcmpHeader.i_type; LDestPort := pIcmpHeader.i_code; //TcpData:=buf+iIphLen+sizeof(pIcmpHeader); //data_size:=iBufSize-iIphLen-sizeof(pIcmpHeader); end; else begin //LSourcePort :=0; LDestPort := 0; //TcpData:=buf+iIphLen; //data_size:=iBufSize-iIphLen; end; end; if StrLIComp(szDestIP,pchar(localIp),9)=0 then begin direct:='0'; Proto:=string(szProtocol); remoteIP:=string(szSourceIP); DestPort:=inttostr(LDestPort); end else begin direct:='1'; Proto:=string(szProtocol); remoteIP:=string(szDestIP); DestPort:=inttostr(LDestPort); end; ///////////// //protoType:='NET'; AllInfo:='8'+direct+'|'+'1'+'|'+proto+'|'+ remoteIP +'|'+ DestPort;//+'|'+ data_size; if (Assigned(FOnCap)) and (iTTL>0) then //FOnCap(dateStr,timeStr,'NET','1',direct,proto,Flag,remoteIP,DestPort,data_size); FOnCap(AllInfo); ///////////// end; function TCapIp.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 TCapIp.WndProc(var MsgRec: TMessage); begin with MsgRec do if (Msg >=WM_CapIp) and (Msg <= WM_CapIp+high(FActiveIP)) then CapIp(msg-WM_CapIp) else Result := DefWindowProc(Handle, Msg, wParam, lParam); end; constructor TCapIp.Create(); begin Fpause:=false; Finitsocket:=false; setlength(Fsocket,0); FWindowHandle := XSocketAllocateHWnd(Self); end; destructor TCapIp.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; end; function TCapIp.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 TCapIp.StartCap; begin if not Finitsocket then if not init_socket then exit; get_ActiveIP; set_socket_state; end; procedure TCapIp.pause; begin if Finitsocket and (high(Fsocket)>-1) then Fpause:=not Fpause; end; procedure TCapIp.StopCap; var i:integer; begin for i:=0 to high(Fsocket) do FCloseSocket(Fsocket[i]); end; end.