{$WARN UNSAFE_TYPE off}
{$WARN UNSAFE_CAST off}
{$WARN UNSAFE_CODE off}
{$WARN SYMBOL_PLATFORM OFF}
{$WARN SYMBOL_LIBRARY OFF}
{$WARN SYMBOL_DEPRECATED OFF}
// must turn off range checking or various records declared array [0..0] die !!!!!
{$R-}
{$Q-}
interface
uses Windows, Messages, SysUtils, Classes, Dialogs, controls, Psapi,
Winsock, TypInfo;
type
TConnInfo =
record
State: Integer;
LocalAddr:
String;
LocalPort: Integer;
RemoteAddr:
String;
RemotePort: Integer;
ProcessID: DWORD;
LocalHost:
string;
RemoteHost:
string;
DispRow: integer;
ProcName: WideString;
CreateDT: TDateTime;
end;
TConnRows =
array of TConnInfo;
implementation
const
ANY_SIZE = 1;
TCPIP_OWNING_MODULE_SIZE = 16;
TCPConnState:
array[0..12]
of string =
('
', '
closed', '
listening', '
syn_sent',
'
syn_rcvd', '
established', '
fin_wait1',
'
fin_wait2', '
close_wait', '
closing',
'
last_ack', '
time_wait', '
delete_tcb'
);
type
PTMibTCPRow = ^TMibTCPRow;
TMibTCPRow =
packed record
dwState: DWORD;
dwLocalAddr: DWORD;
dwLocalPort: DWORD;
dwRemoteAddr: DWORD;
dwRemotePort: DWORD;
end;
PTMibTCPTable = ^TMibTCPTable;
TMibTCPTable =
packed record
dwNumEntries: DWORD;
Table:
array[0..0]
of TMibTCPRow;
end;
PTMibTCPRowEx = ^TMibTCPRowEx;
TMibTCPRowEx =
packed record
dwState: DWord;
dwLocalAddr: DWord;
dwLocalPort: DWord;
dwRemoteAddr: DWord;
dwRemotePort: DWord;
dwProcessID: DWord;
end;
PTMibTCPTableEx = ^TMibTCPTableEx;
TMibTCPTableEx =
packed record
dwNumEntries: Integer;
Table:
array [0..0]
of TMibTCPRowEx;
end;
_MIB_TCPROW_OWNER_MODULE =
record
dwState: DWORD;
dwLocalAddr: DWORD;
dwLocalPort: DWORD;
dwRemoteAddr: DWORD;
dwRemotePort: DWORD;
dwOwningPid: DWORD;
liCreateTimestamp: TFileTime;
{LARGE_INTEGER}
OwningModuleInfo:
Array[0..TCPIP_OWNING_MODULE_SIZE-1]
of int64;
end;
TMibTcpRowOwnerModule = _MIB_TCPROW_OWNER_MODULE;
PTMibTcpRowOwnerModule = ^_MIB_TCPROW_OWNER_MODULE;
_MIB_TCPTABLE_OWNER_MODULE =
record
dwNumEntries: DWORD;
table:
Array[0..ANY_SIZE-1]
of TMibTcpRowOwnerModule;
end;
TMibTcpTableOwnerModule = _MIB_TCPTABLE_OWNER_MODULE;
PTMibTcpTableOwnerModule = ^_MIB_TCPTABLE_OWNER_MODULE;
_TCPIP_OWNER_MODULE_BASIC_INFO =
record
pModuleName: PWCHAR;
pModulePath: PWCHAR;
end;
TTcpIpOwnerModuleBasicInfo = _TCPIP_OWNER_MODULE_BASIC_INFO;
PTcpIpOwnerModuleBasicInfo = ^_TCPIP_OWNER_MODULE_BASIC_INFO;
TTcpIpOwnerModuleBasicInfoEx =
record
TcpIpOwnerModuleBasicInfo: TTcpIpOwnerModuleBasicInfo ;
Buffer:
Array[0..1024]
of byte;
end;
TTcpTableClass = (
TCP_TABLE_BASIC_LISTENER,
TCP_TABLE_BASIC_CONNECTIONS,
TCP_TABLE_BASIC_ALL,
TCP_TABLE_OWNER_PID_LISTENER,
TCP_TABLE_OWNER_PID_CONNECTIONS,
TCP_TABLE_OWNER_PID_ALL,
TCP_TABLE_OWNER_MODULE_LISTENER,
TCP_TABLE_OWNER_MODULE_CONNECTIONS,
TCP_TABLE_OWNER_MODULE_ALL) ;
TTcpIpOwnerModuleInfoClass = (
TcpIpOwnerModuleInfoClassBasic );
Var
GetExtendedTcpTable :
function ( pTCPTable: Pointer; pDWSize: PDWORD;
bOrder: BOOL; ulAf: LongWord; TableClass: TTcpTableClass; Reserved: LongWord): DWORD;
stdcall;
AllocateAndGetTcpExTableFromStack:
procedure (
var pTCPTableEx: PTMibTCPTableEx;
bOrder: Bool; Heap: THandle; Zero, Flags: DWORD);
stdcall;
GetOwnerModuleFromTcpEntry:
function( pTcpEntry: PTMibTcpRowOwnerModule;
InfoClass: TTcpIpOwnerModuleInfoClass; pBuffer: Pointer; pdwSize: PDWORD): LongInt
stdcall ;
GetTcpTable:
function ( pTCPTable: PTMibTCPTable; pDWSize: PDWORD;
bOrder: BOOL ): DWORD;
stdcall;
const
IpHlpDLL = '
IPHLPAPI.DLL';
var
IpHlpModule: THandle;
function LoadIpHlp:Boolean;
begin
Result := True;
if IpHlpModule <> 0
then Exit;
IpHlpModule := LoadLibrary (IpHlpDLL);
if IpHlpModule = 0
then
begin
Result := false;
exit;
end ;
GetTcpTable := GetProcAddress (IpHlpModule, '
GetTcpTable') ;
AllocateAndGetTcpExTableFromStack := GetProcAddress (IpHlpModule,'
AllocateAndGetTcpExTableFromStack') ;
GetExtendedTcpTable := GetProcAddress (IpHlpModule, '
GetExtendedTcpTable') ;
GetOwnerModuleFromTcpEntry := GetProcAddress (IpHlpModule, '
GetOwnerModuleFromTcpEntry') ;
end;
function IpAddr2Str( IPAddr: DWORD ):
string;
var i:integer;
begin
Result := '
';
for i := 1
to 4
do
begin
Result := Result + Format( '
%3d.', [IPAddr
and $FF] );
IPAddr := IPAddr
shr 8;
end;
Delete( Result, Length( Result ), 1 );
end;
function Port2Wrd( nwoPort: DWORD ): DWORD;
begin
Result := Swap( WORD( nwoPort ) );
end;
function FileTimeToInt64 (
const FileTime: TFileTime): Int64 ;
begin
Move (FileTime, result, SizeOf (result)) ;
end;
const
FileTimeBase = -109205.0;
// days between years 1601 and 1900
FileTimeStep: Extended = 24.0 * 60.0 * 60.0 * 1000.0 * 1000.0 * 10.0;
// 100 nsec per Day
function FileTimeToDateTime(
const FileTime: TFileTime): TDateTime;
begin
Result := FileTimeToInt64 (FileTime) / FileTimeStep ;
Result := Result + FileTimeBase ;
end;
procedure IpTCPTable(
var ConnRows: TConnRows);
var
i, ExBufSize, NumEntries : integer;
TableSize, ModSize : DWORD;
ErrorCode, ErrorCode2 : DWORD;
pTCPTable : PTMibTCPTable ;
pTCPTableEx : PTMibTCPTableEx;
pTCPTableEx2 : PTMibTCPTableOwnerModule;
ExFlag, ExFlag2 : boolean ;
TcpIpOwnerModuleBasicInfoEx: TTcpIpOwnerModuleBasicInfoEx ;
LocalFileTime: TFileTime ;
begin
if NOT LoadIpHlp
then exit ;
TableSize := 0 ;
ExBufSize := 0 ;
SetLength (ConnRows, 0) ;
ExFlag := false ;
ExFlag2 := Assigned (GetExtendedTcpTable) ;
if NOT ExFlag2
then ExFlag := Assigned (AllocateAndGetTcpExTableFromStack) ;
pTCPTable :=
Nil ;
pTCPTableEx2 :=
Nil ;
try
// use latest API XP SP2, W2K3 SP1, Vista and later, first call : get size of table
if ExFlag2
then
begin
ErrorCode := GetExtendedTCPTable(
Nil, @TableSize, false, AF_INET, TCP_TABLE_OWNER_MODULE_ALL, 0);
if Errorcode <> ERROR_INSUFFICIENT_BUFFER
then
EXIT;
// get required size of memory, call again
GetMem(pTCPTableEx2, TableSize);
// get table
ErrorCode := GetExtendedTCPTable(pTCPTableEx2, @TableSize, true, AF_INET, TCP_TABLE_OWNER_MODULE_ALL, 0);
if ErrorCode <> NO_ERROR
then
exit ;
NumEntries := pTCPTableEx2^.dwNumEntries;
if NumEntries = 0
then
exit;
SetLength(ConnRows, NumEntries);
for I := 0
to Pred (NumEntries)
do
begin
with ConnRows [I], pTCPTableEx2^.Table [I]
do
begin
ProcName := '
' ;
State := dwState ;
LocalAddr := IpAddr2Str (dwLocalAddr) ;
LocalPort := Port2Wrd (dwLocalPort) ;
RemoteAddr := IPAddr2Str (dwRemoteAddr) ;
RemotePort := Port2Wrd (dwRemotePort) ;
if dwRemoteAddr = 0
then
RemotePort := 0;
FileTimeToLocalFileTime (liCreateTimestamp, LocalFileTime) ;
CreateDT := FileTimeToDateTime (LocalFileTime) ;
ProcessID := dwOwningPid ;
if ProcessID > 0
then
begin
ModSize := SizeOf (TcpIpOwnerModuleBasicInfoEx) ;
ErrorCode2 := GetOwnerModuleFromTcpEntry ( @pTCPTableEx2^.Table [I],
TcpIpOwnerModuleInfoClassBasic, @TcpIpOwnerModuleBasicInfoEx, @ModSize);
if ErrorCode2 = NO_ERROR
then
ProcName := TcpIpOwnerModuleBasicInfoEx.TcpIpOwnerModuleBasicInfo.pModulePath ;
end;
end;
end;
end
// use originally undocumented API, XP only, not Vista
else if ExFlag
then
begin
AllocateAndGetTcpExTableFromStack (pTCPTableEx, true, GetProcessHeap, 2, 2);
ExBufSize := HeapSize (GetProcessHeap, 0, pTCPTableEx);
if ExBufSize = 0
then
exit;
NumEntries := pTCPTableEx^.dwNumEntries ;
if NumEntries = 0
then
exit;
SetLength (ConnRows, NumEntries);
for I := 0
to Pred (NumEntries)
do
begin
with ConnRows [I], pTCPTableEx^.Table [I]
do
begin
ProcName := '
';
CreateDT := 0;
State := dwState;
LocalAddr := IpAddr2Str (dwLocalAddr);
LocalPort := Port2Wrd (dwLocalPort);
RemoteAddr := IPAddr2Str (dwRemoteAddr);
RemotePort := Port2Wrd (dwRemotePort);
if dwRemoteAddr = 0
then
RemotePort := 0;
ProcessID := dwProcessID;
end;
end;
end
else
begin
// use older documented API, first call : get size of table
ErrorCode := GetTCPTable (
Nil, @TableSize, false );
// Angus
if Errorcode <> ERROR_INSUFFICIENT_BUFFER
then
EXIT;
// get required size of memory, call again
GetMem (pTCPTable, TableSize);
// get table
ErrorCode := GetTCPTable (pTCPTable, @TableSize, true);
if ErrorCode <> NO_ERROR
then
exit;
NumEntries := pTCPTable^.dwNumEntries;
if NumEntries = 0
then
exit;
SetLength (ConnRows, NumEntries) ;
for I := 0
to Pred (NumEntries)
do
begin
with ConnRows [I], pTCPTable^.Table [I]
do
begin
ProcName := '
';
CreateDT := 0;
State := dwState;
LocalAddr := IpAddr2Str(dwLocalAddr);
LocalPort := Port2Wrd(dwLocalPort);
RemoteAddr := IPAddr2Str(dwRemoteAddr);
RemotePort := Port2Wrd(dwRemotePort);
if dwRemoteAddr = 0
then
RemotePort := 0;
ProcessID := 0 ;
end;
end;
end;
finally
if ExFlag2
then
begin
if pTCPTableEx2 <>
Nil then
FreeMem (pTCPTableEx2);
end
else if ExFlag
then
begin
if ExBufSize <> 0
then
HeapFree (GetProcessHeap, 0, pTCPTableEx);
end
else if pTCPTable <>
Nil then
FreeMem (pTCPTable);
end;
end;