Indy 组件是一套开放源代码的Blocking模式Socket组件，可以从这里免费下载：
 www.nevrona.com/indy.

本示例程序可在这里下载

{----------------------------------------------------------------------
 Unit Name: sUnit
 Author:    Mats Asplund, 2001-11-09
 Purpose:   Indy client/server示例, 服务器部分
----------------------------------------------------------------------}

unit sUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, 
  Controls, Forms, Dialogs, IdBaseComponent, IdComponent, IdTCPServer, 
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;
    Timer1: TTimer;
    Memo1: TMemo;
    Label2: TLabel;
    Edit1: TEdit;
    procedure IdTCPServer1Execute(AThread: TIdPeerThread);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure IdTCPServer1Connect(AThread: TIdPeerThread);
    procedure IdTCPServer1Disconnect(AThread: TIdPeerThread);
    procedure FormActivate(Sender: TObject);
  private
    ClientList: TStringList;
    ClientStatus: array[0..9] of TShape;
    procedure ShowClientStatus;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses IdTCPConnection;

{$R *.dfm}

procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
  ClientMsg: string;
begin
  with AThread.Connection do
  begin
// 读信息
    ClientMsg := ReadLn('', -2);
// 如果客户端断开连接，则从ClintList中删除之
    if Pos('disconnecting...', ClientMsg) > 1 then
    begin
      ClientList.Delete(ClientList.IndexOf(Copy(ClientMsg, 7, 1)));
      ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Visible := false;
    end
    else
// 否则按客户端状态更新图块
      if Pos('working', ClientMsg) > 1 then
      begin
        ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Visible := true;
        ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Brush.Color := clLime;
      end
      else
      begin
        ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Visible := true;
        ClientStatus[StrToInt(Copy(ClientMsg, 7, 1))].Brush.Color := clRed;
      end;
    Edit1.Text := ClientMsg;
  end;
  ShowClientStatus;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ClientList := TStringList.Create;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  n: integer;
begin
  ClientList.Free;
  for n := 0 to 9 do
    ClientStatus[n].Free;
end;

procedure TForm1.ShowClientStatus;
begin
  Memo1.Lines.Text := ClientList.Text;
end;

procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);
var
  n: integer;
  Full: boolean;
begin
  with AThread.Connection do
  begin
    Full:= true;
    for n := 0 to 9 do
// 取第一个空闲的标识
      if (ClientList.IndexOf(IntToStr(n)) = -1) then
      begin
        ClientList.Add(IntToStr(n));
// 将标识返回到客户端
        WriteLn(IntToStr(n));
        Full:= false;
        Break;
      end;
    if Full then WriteLn('Server full');
  end;
  ShowClientStatus;
end;

procedure TForm1.IdTCPServer1Disconnect(AThread: TIdPeerThread);
begin
  ShowClientStatus;
end;

procedure TForm1.FormActivate(Sender: TObject);
var
  n: integer;
begin
// 建立十个不可见的块图
  for n := 0 to 9 do
  begin
    ClientStatus[n] := TShape.Create(Self);
    ClientStatus[n].Parent := Form1;
    ClientStatus[n].Height := 10;
    ClientStatus[n].Width := 10;
    ClientStatus[n].Shape := stRectangle;
    ClientStatus[n].Top := 35;
    ClientStatus[n].Left := 8 + (15 * n);
    ClientStatus[n].Visible := false;
  end;
end;

end.

{----------------------------------------------------------------------
 Unit Name: cUnit
 Author:    Mats Asplund, 2001-11-09
 Purpose:   Indy client/server示例, 客户端部分
----------------------------------------------------------------------}

unit cUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, 
  Controls, Forms, Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, 
  IdTCPClient, ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Timer1: TTimer;
    IdTCPClient1: TIdTCPClient;
    Label1: TLabel;
    Shape1: TShape;
    Edit1: TEdit;
    Label2: TLabel;
    Button1: TButton;
    procedure Timer1Timer(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    ServerDown, Idle: Boolean;
    ClientNo: string;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  try
    with IdTCPClient1 do
    begin
      Timer1.Interval:= 5000;
// Turn off timer in case of server going down.
      Timer1.Enabled:= false;
      Idle:= not Idle;
      if Idle then
      begin
        Writeln('Client' + ClientNo + ' idle...');
        Shape1.Brush.Color:= clRed;
// Turn it on again
        Timer1.Enabled:= true;
      end
      else
      begin
        Writeln('Client' + ClientNo + ' working...');
        Shape1.Brush.Color:= clLime;
// Turn it on again
        Timer1.Enabled:= true;
      end;
    end;
  except
    on E: Exception do
    begin
      MessageDlg('The server is down.' + #13#10 +
        'Restart the client some other time.', mtError, [mbOK], 0);
      LAbel1.Caption:= 'No contact with server..';
      ServerDown:= true;
    end;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if not ServerDown then
    with IdTCPClient1 do
    begin
      Writeln('Client' + ClientNo + ' disconnecting...');
      Disconnect;
    end;
  Action:= caFree;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  try
    Timer1.Interval:= 1000;
    Timer1.Enabled:= true;
// 连接到服务器
    with IdTCPClient1 do
    begin
      Host:= Edit1.Text;
      Connect;
// 读服务器返回的标识
      ClientNo:= Readln('', 5000); // Timeout 5 secs
      if ClientNo = 'Server full' then
      begin
        MessageDlg('There''s already ten clients connected. ' + #13#10 +
          'Try connecting some other time !', mtWarning, [mbOK], 0);
      end
      else
        if ClientNo = '' then
        begin
          Label1.Caption:= 'Client' + ClientNo + ' connection refused...';
        end
        else
        begin
// Connection accepted by server.
          ServerDown:= false;
          Caption:= 'Client' + ClientNo;
          Button1.Enabled:= false;
          Label1.Caption:= 'Client' + ClientNo + ' connection accepted...';
        end;
    end;
  except
    on E: Exception do
    begin
      Label1.Caption:= 'Client' + ClientNo + ' connection refused...';
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ServerDown:= true;
end;

end.