unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  ialogs, StdCtrls, Winsock;

// так как в примере используются недокументированные функции присутствующие
// только в ХР и выше - то часть кода сделал через директивы компилятора
// (лень было делать динамическую загрузку)
// Если они вам нужны раскоментируйте директиву USES_NATIVE_API

{$DEFINE USES_NATIVE_API}

const
  TH32CS_SNAPPROCESS  = $00000002;

  // Константы состояний порта
  MIB_TCP_STATE_CLOSED     = 1;
  MIB_TCP_STATE_LISTEN     = 2;
  MIB_TCP_STATE_SYN_SENT   = 3;
  MIB_TCP_STATE_SYN_RCVD   = 4;
  MIB_TCP_STATE_ESTAB      = 5;
  MIB_TCP_STATE_FIN_WAIT1  = 6;
  MIB_TCP_STATE_FIN_WAIT2  = 7;
  MIB_TCP_STATE_CLOSE_WAIT = 8;
  MIB_TCP_STATE_CLOSING    = 9;
  MIB_TCP_STATE_LAST_ACK   = 10;
  MIB_TCP_STATE_TIME_WAIT  = 11;
  MIB_TCP_STATE_DELETE_TCB = 12;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    function PortStateToStr(const State: DWORD): String;
  end;

  // Стандартная структура для получения ТСР статистики
  PTMibTCPRow = ^TMibTCPRow;
  TMibTCPRow = packed record
    dwState: DWORD;
    dwLocalAddr: DWORD;
    dwLocalPort: DWORD;
    dwRemoteAddr: DWORD;
    dwRemotePort: DWORD;
  end;

  // В данную структуру будет передаваться результат GetTcpTable
  PTMibTCPTable = ^TMibTCPTable;
  TMibTCPTable = packed record
    dwNumEntries: DWORD;
    Table: array[0..0] of TMibTCPRow;
  end;

  // Стандартная структура для получения UDP статистики
  PTMibUdpRow = ^TMibUdpRow;
  TMibUdpRow = packed record
    dwLocalAddr: DWORD;
    dwLocalPort: DWORD;
  end;

  // В данную структуру будет передаваться результат GetUDPTable
  PTMibUdpTable = ^TMibUdpTable;
  TMibUdpTable = packed record
    dwNumEntries: DWORD;
    table: array [0..0] of TMibUdpRow;
  end;


  {$IFDEF USES_NATIVE_API}
    // Расширенные варианты данных структур

    PTMibTCPExRow = ^TMibTCPExRow;
    TMibTCPExRow = packed record
      dwState: DWORD;
      dwLocalAddr: DWORD;
      dwLocalPort: DWORD;
      dwRemoteAddr: DWORD;
      dwRemotePort: DWORD;
      dwProcessID: DWORD;
    end;

    PTMibTCPExTable = ^TMibTCPExTable;
    TMibTCPExTable = packed record
      dwNumEntries: DWORD;
      Table: array[0..0] of TMibTCPExRow;
    end;

    PTMibUdpExRow = ^TMibUdpExRow;
    TMibUdpExRow = packed record
      dwLocalAddr: DWORD;
      dwLocalPort: DWORD;
      dwProcessID: DWORD;
    end;

    PTMibUdpExTable = ^TMibUdpExTable;
    TMibUdpExTable = packed record
      dwNumEntries: DWORD;
      table: array [0..0] of TMibUdpExRow;
    end;

    // Структура для получения списка текущий процессов и их параметров
    TProcessEntry32 = packed record
      dwSize: DWORD;
      cntUsage: DWORD;
      th32ProcessID: DWORD;
      th32DefaultHeapID: DWORD;
      th32ModuleID: DWORD;
      cntThreads: DWORD;
      th32ParentProcessID: DWORD;
      pcPriClassBase: Longint;
      dwFlags: DWORD;
      szExeFile: array [0..MAX_PATH - 1] of WideChar;
    end;

  {$ENDIF}

  function GetTcpTable(pTCPTable: PTMibTCPTable; var pDWSize: DWORD;
    bOrder: BOOL): DWORD; stdcall; external 'IPHLPAPI.DLL';

  function GetUdpTable(pUDPTable: PTMibUDPTable; var pDWSize: DWORD;
    bOrder: BOOL): DWORD; stdcall; external 'IPHLPAPI.DLL';

  {$IFDEF USES_NATIVE_API}

    function AllocateAndGetTcpExTableFromStack(pTCPExTable: PTMibTCPExTable;
      bOrder: BOOL; heap: THandle; zero: DWORD; flags: DWORD): DWORD; stdcall;
      external 'IPHLPAPI.DLL';

    function AllocateAndGetUdpExTableFromStack(pUDPExTable: PTMibUDPExTable;
      bOrder: BOOL; heap: THandle; zero: DWORD; flags: DWORD): DWORD; stdcall;
      external 'IPHLPAPI.DLL';

    function CreateToolhelp32Snapshot(dwFlags, th32ProcessID: DWORD): THandle;
      stdcall; external 'KERNEL32.DLL';

    function Process32First(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL;
      stdcall; external 'KERNEL32.DLL' name 'Process32FirstW';

    function Process32Next(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL;
      stdcall; external 'KERNEL32.DLL' name 'Process32NextW';

  {$ENDIF}

var
  Form1: TForm1;

implementation

{$R *.dfm}

// Получение TCP/UDP статистики при помощи стандартных методов
procedure TForm1.Button1Click(Sender: TObject);
var
  Size: DWORD;
  TCPTable: PTMibTCPTable;
  UDPTable: PTMibUdpTable;
  I: DWORD;
begin
  // для успешного получения стстаистики первоначально необходимо определиться
  // сколько памяти потребует данная операция
  // для этого делаем так:
  // Вделяем память под TCP таблицу (под один элемент)
  GetMem(TCPTable, SizeOf(TMibTCPTable));
  try
    // Показываем что памяти у нас не выделено
    Size := 0;
    // Выполняем функцию и после этого переменная Size
    // будет содержать кол-во необходимой памяти
    if GetTcpTable(TCPTable, Size, True) <> ERROR_INSUFFICIENT_BUFFER then Exit;
  finally
    // освобождаем память занятую под один элемент
    FreeMem(TCPTable);
  end;
  // Теперь выделяем уже требуемое кол-во памяти
  GetMem(TCPTable, Size);
  try
    // Выполняем функцию
    if GetTcpTable(TCPTable, Size, True) = NO_ERROR then
    begin
      Memo1.Lines.Add('');
      Memo1.Lines.Add('Standart TCP Stats');
      Memo1.Lines.Add(Format('%15s: | %5s %-12s', ['Host', 'Port', 'State']);
      Memo1.Lines.Add('==================================================');
    // и насинаем выводить данные по ТСР
    for I := 0 to TCPTable^.dwNumEntries - 1 do
      Memo1.Lines.Add(Format('%15s: | %5d %s', [inet_ntoa(in_addr(TCPTable^.Table[I].dwLocalAddr)),
        htons(TCPTable^.Table[I].dwLocalPort), PortStateToStr(TCPTable^.Table[I].dwState)]);
    end;
  finally
    // Не забываем освободить память
    FreeMem(TCPTable);
  end;

  // По аналогии поступаем и с UDP статистикой
  GetMem(UDPTable, SizeOf(TMibUDPTable));
  try
    Size := 0;
    if GetUdpTable(UDPTable, Size, True) <> ERROR_INSUFFICIENT_BUFFER then Exit;
  finally
    FreeMem(UDPTable);
  end;
  GetMem(UDPTable, Size);
  try
    if GetUdpTable(UDPTable, Size, True) = NO_ERROR then
    begin
      Memo1.Lines.Add('');
      Memo1.Lines.Add('Standart UDP Stats');
      Memo1.Lines.Add(Format('%15s: | %5s', ['Host', 'Port']);
      Memo1.Lines.Add('======================================');
    for I := 0 to UDPTable^.dwNumEntries - 1 do
      Memo1.Lines.Add(Format('%15s: | %5d', [inet_ntoa(in_addr(UDPTable^.Table[I].dwLocalAddr)),
        htons(UDPTable^.Table[I].dwLocalPort)]);
    end;
  finally
    FreeMem(UDPTable);
  end;
end;

{$IFNDEF USES_NATIVE_API}
procedure TForm1.Button2Click(Sender: TObject);
begin
  Memo1.Lines.Add('');
  Memo1.Lines.Add('USES_NATIVE_API are disabled.');
end;

{$ELSE}

// Получение TCP/UDP статистики при помощи недокументрированных методов
// Работает только на ХР или Win 2003
procedure TForm1.Button2Click(Sender: TObject);

  // данная функция ищет процесс с th32ProcessID совпадающий с ProcessId
  // и возвращает его имя
  function ProcessPIDToName(const hProcessSnap: THandle; ProcessId: DWORD): String;
  var
    processEntry: TProcessEntry32;
  begin
    // Подготовительные действия
    Result := '';
    FillChar(processEntry, SizeOf(TProcessEntry32), #0);
    processEntry.dwSize := SizeOf(TProcessEntry32);
    // Прыгаем на первый процесс в списке
    if not Process32First(hProcessSnap, processEntry) then Exit;
    repeat
      // Сравнение
      if processEntry.th32ProcessID = ProcessId then
      begin
        // Если нашли нужный процесс - выводим результат и выходим
        Result := String(processEntry.szExeFile);
        Exit;
      end;
    // ищем пока не кончатся процессы
    until not Process32Next(hProcessSnap, processEntry);
  end;

var
  TCPExTable: PTMibTCPExTable;
  UDPExTable: PTMibUdpExTable;
  I: DWORD;
  hProcessSnap: THandle;
begin
  // для определения каким процессом открыт тот или иной порт
  // получаем список процессов
  hProcessSnap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if (hProcessSnap = INVALID_HANDLE_VALUE) then
  begin
    Memo1.Lines.Add('');
    Memo1.Lines.Add('CreateToolhelp32Snapshot failed');
    Exit;
  end;
  try
    // Выполняем вот такую вот функцию
    // она не документтрованна, но как видно из названия - она сама выделяет необходимую для работы
    // память и нам остается только прочитать результат по завершении ее выполнения
    if AllocateAndGetTcpExTableFromStack(@TCPExTable, False, GetProcessHeap, 2, 2) = NO_ERROR then
    try
      Memo1.Lines.Add('');
      Memo1.Lines.Add('Extended TCP Stats');
      Memo1.Lines.Add(Format('%15s: | %5s | %-12s | %20s | (%s)', ['Host', 'Port', 'State', 'Process name', 'ID']);
      Memo1.Lines.Add('==========================================================================');
      // начинаем выводить информацию
      for I := 0 to TCPExTable^.dwNumEntries - 1 do
        Memo1.Lines.Add(Format('%15s: | %5d | %-12s | %20s | (%d)',
          [inet_ntoa(in_addr(TCPExTable^.Table[I].dwLocalAddr)),
          htons(TCPExTable^.Table[I].dwLocalPort),
          PortStateToStr(TCPExTable^.Table[I].dwState),
          // Вот здесь у нас происходит сопоставление процесса открытому порту
          ProcessPIDToName(hProcessSnap, TCPExTable^.Table[I].dwProcessID),
          TCPExTable^.Table[I].dwProcessID]);
    finally
      // Не забываем освободить память занятую функцией
      GlobalFreePtr(TCPExTable);
    end;

    // По аналогии поступаем и с UDP статистикой
    if AllocateAndGetUdpExTableFromStack(@UDPExTable, False, GetProcessHeap, 2, 2) = NO_ERROR then
    try
      Memo1.Lines.Add('');
      Memo1.Lines.Add('Extended UDP Stats');
      Memo1.Lines.Add(Format('%15s: | %5s | %20s | (%s)', ['Host', 'Port', 'Process name', 'ID']);
      Memo1.Lines.Add('==============================================================');
      // начинаем выводить информацию
      for I := 0 to UDPExTable^.dwNumEntries - 1 do
        Memo1.Lines.Add(Format('%15s: | %5d | %20s | (%d)',
          [inet_ntoa(in_addr(UDPExTable^.Table[I].dwLocalAddr)),
          htons(UDPExTable^.Table[I].dwLocalPort),
          ProcessPIDToName(hProcessSnap, UDPExTable^.Table[I].dwProcessID),
          UDPExTable^.Table[I].dwProcessID]);
    finally
      GlobalFreePtr(UDPExTable);
    end;
  finally
    // Закрываем хэндл полученый от CreateToolhelp32Snapshot
    CloseHandle(hProcessSnap);
  end;
end;

{$ENDIF}

// Функция преобразует состояние порта в строковый эквивалент
function TForm1.PortStateToStr(const State: DWORD): String;
begin
  case State of
    MIB_TCP_STATE_CLOSED: Result := 'CLOSED';
    MIB_TCP_STATE_LISTEN: Result := 'LISTEN';
    MIB_TCP_STATE_SYN_SENT: Result := 'SYN SENT';
    MIB_TCP_STATE_SYN_RCVD: Result := 'SYN RECEIVED';
    MIB_TCP_STATE_ESTAB: Result := 'ESTABLISHED';
    MIB_TCP_STATE_FIN_WAIT1: Result := 'FIN WAIT 1';
    MIB_TCP_STATE_FIN_WAIT2: Result := 'FIN WAIT 2';
    MIB_TCP_STATE_CLOSE_WAIT: Result := 'CLOSE WAIT';
    MIB_TCP_STATE_CLOSING: Result := 'CLOSING';
    MIB_TCP_STATE_LAST_ACK: Result := 'LAST ACK';
    MIB_TCP_STATE_TIME_WAIT: Result := 'TIME WAIT';
    MIB_TCP_STATE_DELETE_TCB: Result := 'DELETE TCB';
  else
    Result := 'UNKNOWN';
  end;
end;


end.

    Structure MIB_TCPROW
        Dim dwState As String
        Dim dwLocalAddr As String
        Dim dwLocalPort As String
        Dim dwRemoteAddr As String
        Dim dwRemotePort As String
    End Structure
    Structure MIB_TCPTABLE
        Dim dwNumEntries As Integer
        Dim table() As MIB_TCPROW
    End Structure

    Structure MIB_UDPROW
        Dim dwLocalAddr As String
        Dim dwLocalPort As String
    End Structure
    Structure MIB_UDPTABLE
        Dim dwNumEntries As Integer
        Dim Utable() As MIB_UDPROW
    End Structure

    Declare Auto Function getTcpTable Lib "Iphlpapi.dll" Alias "GetTcpTable" ( _
        ByRef TCPTABLE As MIB_TCPTABLE, _
        ByRef pdwSize As String, _
        ByVal bOrder As Boolean) _
    As Long

    Declare Auto Function getUdpTable Lib "Iphlpapi.dll" Alias "GetUdpTable" ( _
       ByRef UDPTABLE As MIB_UDPTABLE, _
       ByRef pdwSize As String, _
       ByVal bOrder As Boolean) _
    As Long


    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load

        Dim tcpTable As New MIB_TCPTABLE
        Dim pdwSize As String = 200
        Dim bOrder As Boolean = True

        Dim a As Long = getTcpTable(tcpTable, pdwSize, bOrder)
        MsgBox(tcpTable.dwNumEntries)

        Dim udpTable As New MIB_UDPTABLE
        Dim UpdwSize As String = 0
        Dim UbOrderubor As Boolean = True

        Dim b As Long = getUdpTable(udpTable, UpdwSize, UbOrderubor)
        MsgBox(udpTable.dwNumEntries)

    End Sub