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