Delphi2009的Indy全接触之TCP篇

我在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.