delphi idtcpserver&idtcpclient 演示

{----------------------------------------------------------------------

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
.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
:= TShape.Create(Self);

ClientStatus
.Parent := Form1;

ClientStatus
.Height := 10;

ClientStatus
.Width := 10;

ClientStatus
.Shape := stRectangle;

ClientStatus
.Top := 35;

ClientStatus
.Left := 8 + (15 * n);

ClientStatus
.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.