我在Delphi盒子[ http://www.2ccc.com/ ]上找到了一个基于TCP协议的聊天及文件传书工具,于是把他改写成D2009版本的代码。
源代码下载地址: http://www.2ccc.com/article.asp?articleid=3894
步骤如下:
新建服务端工程如下图:

注意:里面使用了线程池TIdSchedulerOfThreadPool控件。关于他的使用范例可参照:http://blog.csdn.net/applebomb/archive/2007/10/29/1854603.aspx
代码如下:unitUnit1;
interface
uses
Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
Dialogs,SyncObjs,IdBaseComponent,IdComponent,IdCustomTCPServer,IdTCPServer,
IdSocketHandle,IdGlobal,IdContext,StdCtrls,ComCtrls,XPMan,Menus,
IdScheduler,IdSchedulerOfThread,IdSchedulerOfThreadPool,IdIPWatch;
type
TUser=class(TObject)
private
FIP,
FUserName:string;
FPort:Integer;
FSelected:Boolean;
FContext:TIdContext;
FLock:TCriticalSection;
FCommandQueues:TThreadList;
FListItem:TListItem;
FWorkSize:Int64;
procedureSetContext(constValue:TIdContext);
procedureSetListItem(constValue:TListItem);
protected
procedureDoWork(ASender:TObject;AWorkMode:TWorkMode;AWorkCount:Int64);
public
constructorCreate(constAIP,AUserName:string;APort:Integer;AContext:TIdContext);reintroduce;
destructorDestroy;override;
procedureLock;
procedureUnlock;
propertyIP:stringreadFIP;
propertyPort:IntegerreadFPort;
propertyUserName:stringreadFUserName;
propertySelected:BooleanreadFSelectedwriteFSelected;
propertyContext:TIdContextreadFContextwriteSetContext;
propertyCommandQueues:TThreadListreadFCommandQueues;
propertyListItem:TListItemreadFListItemwriteSetListItem;
end;
const
WM_REFRESH_USERS=WM_USER+330;
type
TRefreshParam=(rpRefreshAll,rpAppendItem,rpDeleteItem);
PCmdRec=^TCmdRec;
TCmdRec=record
Cmd:string;
end;
TMainForm=class(TForm)
IdTCPServer:TIdTCPServer;
lvUsers:TListView;
Memo1:TMemo;
btnSendFileToClient:TButton;
XPManifest1:TXPManifest;
dlgOpenSendingFile:TOpenDialog;
edtMsg:TEdit;
pmRefresh:TPopupMenu;
mmiRefresh:TMenuItem;
pmClearMemo:TPopupMenu;
miClearLog:TMenuItem;
IdSchedulerOfThreadPool1:TIdSchedulerOfThreadPool;
IdIPWatch:TIdIPWatch;
procedurebtnSendFileToClientClick(Sender:TObject);
procedureedtMsgKeyDown(Sender:TObject;varKey:Word;Shift:TShiftState);
procedureFormClose(Sender:TObject;varAction:TCloseAction);
procedureFormCreate(Sender:TObject);
procedureIdTCPServerConnect(AContext:TIdContext);
procedureIdTCPServerDisconnect(AContext:TIdContext);
procedureIdTCPServerExecute(AContext:TIdContext);
procedurelvUsersChange(Sender:TObject;Item:TListItem;Change:TItemChange);
proceduremiClearLogClick(Sender:TObject);
proceduremmiRefreshClick(Sender:TObject);
private
{Privatedeclarations}
FUsers:TThreadList;
FLockUI:TCriticalSection;
procedureClearUsers;
procedureRefreshUsersInListView;
procedureDeleteUserInListView(AClient:TUser);
procedureAddUserInListView(AClient:TUser);
procedureSendFileToUser(AUser:TUser;constFileName:string);
procedureSendTextToUser(AUser:TUSer;constText:string);
procedureLockUI;
procedureUnlockUI;
procedureWMRefreshUsers(varMsg:TMessage);messageWM_REFRESH_USERS;
public
{Publicdeclarations}
end;
var
MainForm:TMainForm;
implementation
{$R*.dfm}
{TUser}
constructorTUser.Create(constAIP,AUserName:string;APort:Integer;AContext:TIdContext);
begin
FLock:=TCriticalSection.Create;
FIP:=AIP;
FPort:=APort;
FUserName:=AUserName;
Context:=AContext;
FCommandQueues:=TThreadList.Create;
end;
destructorTUser.Destroy;
begin
FCommandQueues.Free;
FLock.Free;
inherited;
end;
procedureTUser.SetContext(constValue:TIdContext);
begin
ifFContext<>nilthenFContext.Data:=nil;
ifValue<>nilthenValue.Data:=Self;
FContext:=Value;
end;
procedureTUser.Lock;
begin
FLock.Enter;
end;
procedureTUser.Unlock;
begin
FLock.Leave;
end;
procedureTUser.SetListItem(constValue:TListItem);
begin
ifFListItem<>Valuethen
FListItem:=Value;
ifValue<>nilthenValue.Data:=Self;
end;
functionGetPercentFrom(Int,Total:Int64):Double;
begin
if(Int=0)or(Total=0)then
Result:=0
elseifInt=Totalthen
Result:=100
elsebegin
Result:=Int/(Total/100);
end;
end;
procedureTUser.DoWork(ASender:TObject;AWorkMode:TWorkMode;
AWorkCount:Int64);
var
NewPercent:string;
begin
ifListItem<>nilthen
begin
NewPercent:=IntToStr(Trunc(GetPercentFrom(AWorkCount,
FWorkSize)))+'%';
ifListItem.SubItems[1]<>NewPercentthenListItem.SubItems[1]:=NewPercent;
end;
end;
{TForm1}
var
FormHanlde:HWND=0;
procedureTMainForm.btnSendFileToClientClick(Sender:TObject);
var
I:Integer;
Client:TUser;
cmds:TList;
CmdRec:PCmdRec;
SendUserCount:Integer;
begin
ifdlgOpenSendingFile.Executethen
begin
lvUsers.Enabled:=False;
try
SendUserCount:=0;
forI:=0tolvUsers.Items.Count-1do
iflvUsers.Items[I].Checkedthen
begin
Client:=TUser(lvUsers.Items[I].Data);
cmds:=Client.CommandQueues.LockList;
try
New(CmdRec);
CmdRec^.Cmd:=Format('SENDF%s',[dlgOpenSendingFile.FileName]);
cmds.Add(CmdRec);
Inc(SendUserCount);
finally
Client.CommandQueues.UnlockList;
end;
end;
finally
lvUsers.Enabled:=True;
end;
ifSendUserCount<=0then
MessageDlg('没有可以发送文件的用户存在!',mtError,[mbOK],0);
end;
end;
procedureTMainForm.FormCreate(Sender:TObject);
begin
FormHanlde:=Self.Handle;
FUsers:=TThreadList.Create;
FLockUI:=TCriticalSection.Create;
withIdTCPServer.Bindings.Adddo
begin
IP:=IdIPWatch.LocalIP;
Port:=3030;
end;
IdTCPServer.Active:=True;
end;
procedureTMainForm.FormClose(Sender:TObject;varAction:TCloseAction);
begin
FormHanlde:=0;
ifIdTCPServer.ActivethenIdTCPServer.Active:=False;
ClearUsers;
FUsers.Free;
FLockUI.Free;
end;
procedureTMainForm.ClearUsers;
var
lst:TList;
I:Integer;
User:TUser;
begin
lst:=FUsers.LockList;
try
forI:=0tolst.Count-1do
begin
User:=lst[I];
ifUser<>nilthenUser.Context:=nil;
User.Free;
end;
FUsers.Clear;
finally
FUsers.UnlockList;
end;
end;
procedureTMainForm.IdTCPServerConnect(AContext:TIdContext);
var
Client:TUser;
AUserName:string;
lst:TList;
I:Integer;
begin
AUserName:=AContext.Connection.IOHandler.ReadLn;
ifAUserName=''then
begin
AContext.Connection.IOHandler.WriteLn('NO_USER_NAME');
AContext.Connection.Disconnect;
Exit;
end;
lst:=FUsers.LockList;
try
forI:=0tolst.Count-1do
ifSameText(TUser(lst[I]).UserName,AUserName)then
begin
AContext.Connection.IOHandler.WriteLn('USER_ALREADY_LOGINED');
AContext.Connection.Disconnect;
Exit;
end;
Client:=TUser.Create(AContext.Binding.PeerIP,AUserName,
AContext.Binding.PeerPort,AContext);
lst.Add(Client);
Client.Lock;
try
Client.Context.Connection.IOHandler.WriteLn('LOGINED');
finally
Client.Unlock;
end;
finally
FUsers.UnlockList;
end;
SendMessage(FormHanlde,WM_REFRESH_USERS,Ord(rpAppendItem),Integer(Client));
end;
procedureTMainForm.IdTCPServerDisconnect(AContext:TIdContext);
var
Client:TUser;
begin
Client:=TUser(AContext.Data);
ifClient<>nilthen
begin
Client.Lock;
try
Client.Context:=nil;
finally
Client.Unlock;
end;
FUsers.Remove(Client);
SendMessage(FormHanlde,WM_REFRESH_USERS,Ord(rpDeleteItem),Integer(Client));
Client.Free;
end;
end;
procedureTMainForm.IdTCPServerExecute(AContext:TIdContext);
var
Client:TUser;
Msg,Cmd:string;
cmds:TList;
CmdRec:PCmdRec;
begin
Client:=TUser(AContext.Data);
ifClient<>nilthen
begin
Client.Lock;
try
AContext.Connection.IOHandler.CheckForDataOnSource(250);
ifnotAContext.Connection.IOHandler.InputBufferIsEmptythen
begin
Msg:=AContext.Connection.IOHandler.ReadLn(enUTF8);
ifFormHanlde<>0then
begin
LockUI;
try
Memo1.Lines.Add(Format('IP:%s的%s用户说:"%s"',[Client.IP,Client.UserName,Msg]));
finally
UnlockUI;
end;
end;
end;
cmds:=Client.CommandQueues.LockList;
try
ifcmds.Count>0then
begin
CmdRec:=cmds[0];
Cmd:=CmdRec.Cmd;
cmds.Delete(0);
Dispose(CmdRec);
end
elseCmd:='';
finally
Client.CommandQueues.UnlockList;
end;
ifCmd=''thenExit;
ifPos('SENDF',Cmd)=1then
begin
ifFormHanlde<>0then
begin
LockUI;
try
Memo1.Lines.Add(Format('发送文件到%s(IP:%s)',[Client.UserName,CLient.IP]));
finally
UnlockUI;
end;
end;
SendFileToUser(Client,Trim(Copy(Cmd,6,Length(Cmd))));
end
elseifPos('SENDT',Cmd)=1then
begin
ifFormHanlde<>0then
begin
LockUI;
try
Memo1.Lines.Add(Format('发送文本信息到%s(IP:%s),文本内容:"%s"',[Client.UserName,Client.IP,Trim(Copy(Cmd,6,Length(Cmd)))]));
finally
UnlockUI;
end;
end;
SendTextToUser(Client,Trim(Copy(Cmd,6,Length(Cmd))));
end;
finally
Client.Unlock;
end;
end;
end;
procedureTMainForm.SendFileToUser(AUser:TUser;constFileName:string);
var
FStream:TFileStream;
Str:string;
begin
ifAUser.Context<>nilthen
withAUser.Contextdo
begin
Connection.IOHandler.WriteLn(Format('FILE%s',[ExtractFileName(FileName)]));
Str:=Connection.IOHandler.ReadLn;
ifSameText(Str,'SIZE')then
begin
FStream:=TFileStream.Create(FileName,fmOpenReador
fmShareDenyWrite);
try
Connection.IOHandler.Write(ToBytes(FStream.Size));
Str:=Connection.IOHandler.ReadLn;
ifSameText(Str,'READY')then
begin
Connection.IOHandler.LargeStream:=True;
Connection.OnWork:=AUser.DoWork;
AUser.FWorkSize:=FStream.Size;
Connection.IOHandler.Write(FStream,FStream.Size);
Connection.OnWork:=nil;
Connection.IOHandler.LargeStream:=False;
Str:=Connection.IOHandler.ReadLn;
ifFormHanlde<>0then
begin
LockUI;
try
ifSameText(Str,'OK')then
Memo1.Lines.Add(Format('用户:%s(IP:%s)已成功接收文件。',[AUser.UserName,AUser.IP]))
else
Memo1.Lines.Add(Format('传输终止!用户:%s,IP:%s',[AUser.UserName,AUser.IP]));
finally
UnlockUI;
end;
end;
Connection.IOHandler.WriteLn('DONE');
end;
finally
FStream.Free;
end;
end;
end;
end;
procedureTMainForm.WMRefreshUsers(varMsg:TMessage);
begin
ifMsg.Msg=WM_REFRESH_USERSthen
begin
caseTRefreshParam(Msg.WParam)of
rpRefreshAll:begin
RefreshUsersInListView;
end;
rpAppendItem:begin
AddUserInListView(TUser(Msg.LParam));
end;
rpDeleteItem:begin
DeleteUserInListView(TUser(Msg.LParam));
end;
end;
end;
end;
procedureTMainForm.DeleteUserInListView(AClient:TUser);
begin
ifAClient.ListItem<>nilthen
AClient.ListItem.Delete;
end;
procedureTMainForm.edtMsgKeyDown(Sender:TObject;varKey:Word;Shift:
TShiftState);
var
I:Integer;
Client:TUser;
cmds:TList;
CmdRec:PCmdRec;
begin
ifKey=VK_RETURNthen
begin
lvUsers.Enabled:=False;
try
forI:=0tolvUsers.Items.Count-1do
begin
ifI=0thenMemo1.Lines.Add('');
iflvUsers.Items[I].Checkedthen
begin
Client:=TUser(lvUsers.Items[I].Data);
ifClient<>nilthen
begin
cmds:=Client.CommandQueues.LockList;
try
New(CmdRec);
CmdRec^.Cmd:=Format('SENDT%s',[edtMsg.Text]);
cmds.Add(CmdRec);
finally
Client.CommandQueues.UnlockList;
end;
end;
end;
end;
edtMsg.Clear;
finally
lvUsers.Enabled:=True;
end;
Key:=0;
end;
end;
procedureTMainForm.RefreshUsersInListView;
var
lst:TList;
I:Integer;
begin
lvUsers.Items.BeginUpdate;
try
lvUsers.Clear;
lst:=FUsers.LockList;
try
forI:=0tolst.Count-1do
SendMessage(FormHanlde,WM_REFRESH_USERS,Ord(rpAppendItem),
Integer(lst[I]));
finally
FUsers.UnlockList;
end;
finally
lvUsers.Items.EndUpdate;
end;
end;
procedureTMainForm.LockUI;
begin
FLockUI.Enter;
end;
procedureTMainForm.UnlockUI;
begin
FLockUI.Leave;
end;
procedureTMainForm.SendTextToUser(AUser:TUSer;constText:string);
begin
ifAUser.Context<>nilthen
withAUser.Contextdo
begin
Connection.IOHandler.WriteLn(Text,enUTF8);
end;
end;
procedureTMainForm.AddUserInListView(AClient:TUser);
var
Item:TListItem;
begin
Item:=lvUsers.Items.Add;
Item.Caption:=AClient.UserName;
AClient.ListItem:=Item;
Item.SubItems.Add(Format('%s[%d]',[AClient.IP,AClient.Port]));
Item.SubItems.Add('N/A');
Item.Checked:=AClient.Selected;
end;
procedureTMainForm.lvUsersChange(Sender:TObject;Item:TListItem;Change:
TItemChange);
begin
if(Change=ctState)and(Item.Data<>nil)then
TUser(Item.Data).Selected:=Item.Checked;
end;
procedureTMainForm.miClearLogClick(Sender:TObject);
begin
LockUI;
try
Memo1.Lines.Clear;
finally
UnlockUI;
end;
end;
procedureTMainForm.mmiRefreshClick(Sender:TObject);
begin
SendMessage(FormHanlde,WM_REFRESH_USERS,Ord(rpRefreshAll),0);
end;
end.
然后是客户端:

代码如下:
unitUnit1;
interface
uses
Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
Dialogs,IdBaseComponent,IdComponent,IdGlobal,IdTCPConnection,IdTCPClient,
ExtCtrls,StdCtrls,ComCtrls,XPMan;
type
TForm1=class(TForm)
IdTCPClient:TIdTCPClient;
btnConnect:TButton;
tmrCheckServerMsg:TTimer;
btnDisconect:TButton;
edtMsg:TEdit;
pbProgress:TProgressBar;
mmoInfo:TMemo;
XPManifest1:TXPManifest;
procedurebtnConnectClick(Sender:TObject);
procedurebtnDisconectClick(Sender:TObject);
procedureedtMsgKeyDown(Sender:TObject;varKey:Word;Shift:TShiftState);
procedureFormClose(Sender:TObject;varAction:TCloseAction);
procedureFormCreate(Sender:TObject);
procedureFormShow(Sender:TObject);
procedureIdTCPClientWork(ASender:TObject;AWorkMode:TWorkMode;AWorkCount:Int64);
proceduretmrCheckServerMsgTimer(Sender:TObject);
private
{Privatedeclarations}
public
{Publicdeclarations}
end;
var
Form1:TForm1;
implementation
usesTypInfo;
{$R*.dfm}
procedureTForm1.btnConnectClick(Sender:TObject);
var
Response:string;
UserName:string;
HostName:array[0..MAX_COMPUTERNAME_LENGTH]ofchar;
Length:DWORD;
begin
IdTCPClient.ConnectTimeout:=5000;
IdTCPClient.Connect;
//UserName:=Format('U%.5d',[Random(99999)]);
Length:=SizeOf(HostName);
GetComputerName(HostName,Length);
UserName:=HostName;
IdTCPClient.IOHandler.WriteLn(UserName);
Response:=IdTCPClient.IOHandler.ReadLn;
ifSameText(Response,'LOGINED')then
begin
btnDisconect.Enabled:=True;
btnConnect.Enabled:=False;
tmrCheckServerMsg.Enabled:=True;
Caption:='Client-'+UserName;
end
elseraiseException.CreateFmt('登录失败:"%s"',[Response]);
end;
procedureTForm1.btnDisconectClick(Sender:TObject);
begin
btnConnect.Enabled:=True;
btnDisconect.Enabled:=False;
tmrCheckServerMsg.Enabled:=False;
Caption:='Client';
IdTCPClient.Disconnect;
end;
procedureTForm1.edtMsgKeyDown(Sender:TObject;varKey:Word;Shift:
TShiftState);
begin
ifKey=VK_RETURNthen
begin
ifnotIdTCPClient.ConnectedthenExit;
ifedtMsg.Text<>''then
begin
IdTCPClient.IOHandler.WriteLn(edtMsg.Text,enUTF8);
mmoInfo.Lines.Add(Format('发送消息:"%s"',[edtMsg.Text]));
edtMsg.Clear;
end;
Key:=0;
end;
end;
procedureTForm1.FormClose(Sender:TObject;varAction:TCloseAction);
begin
try
ifIdTCPClient.Connectedthen
btnDisconect.Click;
except
end;
end;
procedureTForm1.FormCreate(Sender:TObject);
begin
Randomize;
IdTCPClient.Host:='192.168.2.148';
IdTCPClient.Port:=3030;
end;
procedureTForm1.FormShow(Sender:TObject);
begin
btnConnect.Click;
end;
procedureTForm1.IdTCPClientWork(ASender:TObject;AWorkMode:TWorkMode;
AWorkCount:Int64);
begin
pbProgress.Position:=AWorkCount;
Application.ProcessMessages;
end;
type
TSizeType=(stB,stK,stM,stG,stT);
functionFormatFileSize(Size:Extended;MaxSizeType:TSizeType;varReturnSizeType:TSizeType;
constIncludeComma:Boolean=True):string;overload;
const
FormatStr:array[Boolean]ofstring=('0.##','#,##0.##');{donotlocalize}
var
DivCount:Integer;
begin
ReturnSizeType:=stB;
DivCount:=0;
while(Size>=1024)and(ReturnSizeType<>MaxSizeType)do
begin
Size:=Size/1024;
Inc(DivCount);
caseDivCountof
1:ReturnSizeType:=stK;
2:ReturnSizeType:=stM;
3:ReturnSizeType:=stG;
4:ReturnSizeType:=stT;
end;
end;
Result:=FormatFloat(FormatStr[IncludeComma],Size);
end;
functionFormatFileSize(Size:Extended;MaxSizeType:TSizeType;
constIncludeComma:Boolean=True):string;overload;
resourcestring
RSC_BYTE='字节';
var
ReturnSt:TSizeType;
begin
Result:=FormatFileSize(Size,stT,ReturnSt,True)+''+
Copy(GetEnumName(TypeInfo(TSizeType),Ord(ReturnSt)),3,1);
ifReturnSt=stBthen
begin
Delete(Result,Length(Result),1);
Result:=Result+RSC_BYTE;
end
else
Result:=Result+'B';{donotlocalize}
end;
procedureTForm1.tmrCheckServerMsgTimer(Sender:TObject);
var
CmdStr:string;
FSize:Int64;
FStream:TFileStream;
SaveFileName:string;
begin
CmdStr:='';
ifIdTCPClient.Connectedthen
begin
IdTCPClient.IOHandler.CheckForDataOnSource(250);
ifnotIdTCPClient.IOHandler.InputBufferIsEmptythen
begin
tmrCheckServerMsg.Enabled:=False;
try
CmdStr:=IdTCPClient.IOHandler.ReadLn(enUTF8);
CmdStr:=System.UTF8Encode(CmdStr);
ifSameText(Copy(CmdStr,1,4),'FILE')then
begin
SaveFileName:=Trim(Copy(CmdStr,5,Length(CmdStr)));
mmoInfo.Lines.Add('准备接收文件....');
IdTCPClient.IOHandler.WriteLn('SIZE');
FSize:=IdTCPClient.IOHandler.ReadInt64(False);
ifFSize>0then
begin
pbProgress.Max:=FSize;
pbProgress.Position:=0;
mmoInfo.Lines.Add('文件大小='+FormatFileSize(FSize,stK)+';正在接收中...');
IdTCPClient.IOHandler.WriteLn('READY');
whileTruedo
begin
ifFileExists(ExtractFilePath(ParamStr(0))+SaveFileName)then
SaveFileName:='~'+SaveFileName
elseBreak;
end;
FStream:=TFileStream.Create(ExtractFilePath(ParamStr(0))
+SaveFileName,
fmCreate);
try
IdTCPClient.IOHandler.LargeStream:=True;
IdTCPClient.IOHandler.ReadStream(FStream,FSize);
IdTCPClient.IOHandler.LargeStream:=False;
IdTCPClient.IOHandler.WriteLn('OK');
ifIdTCPClient.IOHandler.ReadLn='DONE'then
mmoInfo.Lines.Add('接收成功!')
finally
FStream.Free;
end;
end
elsebegin
mmoInfo.Lines.Add('接收失败!');
IdTCPClient.IOHandler.WriteLn('CANCEL');
end;
end
else
mmoInfo.Lines.Add('接收文本信息:'+CmdStr)
finally
tmrCheckServerMsg.Enabled:=True;
end;
end;
end;
end;
end.