Delphi2009的Indy全接触之TCP篇

Delphi2009的Indy全接触之TCP篇2012-02-22 csdn博客【昆山人在上海】我在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
代码如下：
1.unit Unit1;
2.
3.interface
4.
5.uses
6.Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7.Dialogs, SyncObjs, IdBaseComponent, IdComponent, IdCustomTCPServer, IdTCPServer,
8.IdSocketHandle, IdGlobal, IdContext, StdCtrls, ComCtrls, XPMan, Menus,
9.IdScheduler, IdSchedulerOfThread, IdSchedulerOfThreadPool, IdIPWatch;
10.
11.type
12.TUser = class（TObject）
13.private
14.FIP,
15.FUserName: string;
16.FPort: Integer;
17.FSelected: Boolean;
18.FContext: TIdContext;
19.FLock: TCriticalSection;
20.FCommandQueues: TThreadList;
21.FListItem: TListItem;
22.FWorkSize: Int64;
23.procedure SetContext（const Value: TIdContext）;
24.procedure SetListItem（const Value: TListItem）;
25.protected
26.procedure DoWork（ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64）;
27.public
28.constructor Create（const AIP, AUserName: string; APort: Integer; AContext: TIdContext）; reintroduce;
29.destructor Destroy; override;
30.procedure Lock;
31.procedure Unlock;
32.property IP: string read FIP;
33.property Port: Integer read FPort;
34.property UserName: string read FUserName;
35.property Selected: Boolean read FSelected write FSelected;
36.property Context: TIdContext read FContext write SetContext;
37.property CommandQueues: TThreadList read FCommandQueues;
38.property ListItem: TListItem read FListItem write SetListItem;
39.end;
40.
41.const
42.WM_REFRESH_USERS = WM_USER + 330;
43.
44.type
45.TRefreshParam = （rpRefreshAll, rpAppendItem, rpDeleteItem）;
46.
47.PCmdRec = ^TCmdRec;
48.TCmdRec = record49.Cmd: string;
50.end;
51.
52.TMainForm = class（TForm）
53.IdTCPServer: TIdTCPServer;
54.lvUsers: TListView;
55.Memo1: TMemo;
56.btnSendFileToClient: TButton;
57.XPManifest1: TXPManifest;
58.dlgOpenSendingFile: TOpenDialog;
59.edtMsg: TEdit;
60.pmRefresh: TPopupMenu;
61.mmiRefresh: TMenuItem;
62.pmClearMemo: TPopupMenu;
63.miClearLog: TMenuItem;
64.IdSchedulerOfThreadPool1: TIdSchedulerOfThreadPool;
65.IdIPWatch: TIdIPWatch;
66.procedure btnSendFileToClientClick（Sender: TObject）;
67.procedure edtMsgKeyDown（Sender: TObject; var Key: Word; Shift: TShiftState）;
68.procedure FormClose（Sender: TObject; var Action: TCloseAction）;
69.procedure FormCreate（Sender: TObject）;
70.procedure IdTCPServerConnect（AContext: TIdContext）;
71.procedure IdTCPServerDisconnect（AContext: TIdContext）;
72.procedure IdTCPServerExecute（AContext: TIdContext）;
73.procedure lvUsersChange（Sender: TObject; Item: TListItem; Change: TItemChange）;
74.procedure miClearLogClick（Sender: TObject）;
75.procedure mmiRefreshClick（Sender: TObject）;
76.private
77.{ Private declarations }
78.FUsers: TThreadList;
79.FLockUI: TCriticalSection;
80.procedure ClearUsers;
81.procedure RefreshUsersInListView;
82.procedure DeleteUserInListView（AClient: TUser）;
83.procedure AddUserInListView（AClient: TUser）;
84.procedure SendFileToUser（AUser: TUser; const FileName: string）;
85.procedure SendTextToUser（AUser: TUSer; const Text: string）;
86.procedure LockUI;
87.procedure UnlockUI;
88.procedure WMRefreshUsers（var Msg: TMessage）; message WM_REFRESH_USERS;
89.public
90.{ Public declarations }
91.end;
92.
93.var
94.MainForm: TMainForm;
95.
96.implementation
97.
98.{$R *.dfm}
99.
100.{ TUser }
101.
102.constructor TUser.Create（const AIP, AUserName: string; APort: Integer; AContext: TIdContext）;
103.begin
104.FLock := TCriticalSection.Create;
105.FIP := AIP;
106.FPort := APort;
107.FUserName := AUserName;
108.Context := AContext;
109.FCommandQueues := TThreadList.Create;
110.end;
111.
112.destructor TUser.Destroy;
113.begin
114.FCommandQueues.Free;
115.FLock.Free;
116.inherited;
117.end;
118.
119.procedure TUser.SetContext（const Value: TIdContext）;
120.begin
121.if FContext <> nil then FContext.Data := nil;
122.if Value <> nil then Value.Data := Self;
123.FContext := Value;
124.end;
125.
126.procedure TUser.Lock;
127.begin
128.FLock.Enter;
129.end;
130.
131.procedure TUser.Unlock;
132.begin
133.FLock.Leave;
134.end;
135.
136.procedure TUser.SetListItem（const Value: TListItem）;
137.begin
138.if FListItem <> Value then
139.FListItem := Value;
140.if Value <> nil then Value.Data := Self;
141.end;
142.
143.function GetPercentFrom（Int, Total: Int64）: Double;
144.begin
145.if （Int = 0） or （Total = 0） then
146.Result := 0
147.else if Int = Total then
148.Result := 100
149.else begin
150.Result := Int / （Total / 100）;
151.end;
152.end;
153.
154.procedure TUser.DoWork（ASender: TObject; AWorkMode: TWorkMode;
155.AWorkCount: Int64）;
156.var
157.NewPercent: string;
158.begin
159.if ListItem <> nil then
160.begin
161.NewPercent := IntToStr（Trunc（GetPercentFrom（AWorkCount,
162.FWorkSize））） + "%";
163.if ListItem.SubItems[1] <> NewPercent then ListItem.SubItems[1] := NewPercent;
164.end;
165.end;
166.
167.{ TForm1 }
168.
169.var
170.FormHanlde: HWND = 0;
171.
172.procedure TMainForm.btnSendFileToClientClick（Sender: TObject）;
173.var
174.I: Integer;
175.Client: TUser;
176.cmds: TList;
177.CmdRec: PCmdRec;
178.SendUserCount: Integer;
179.begin
180.if dlgOpenSendingFile.Execute then
181.begin
182.lvUsers.Enabled := False;
183.try
184.SendUserCount := 0;
185.for I := 0 to lvUsers.Items.Count - 1 do
186.if lvUsers.Items[I].Checked then
187.begin
188.Client := TUser（lvUsers.Items[I].Data）;
189.cmds := Client.CommandQueues.LockList;
190.try
191.New（CmdRec）;
192.CmdRec^.Cmd := Format（"SENDF %s", [dlgOpenSendingFile.FileName]）;
193.cmds.Add（CmdRec）;
194.Inc（SendUserCount）;
195.finally
196.Client.CommandQueues.UnlockList;
197.end;
198.end;
199.finally
200.lvUsers.Enabled := True;
201.end;
202.if SendUserCount <= 0 then
203.MessageDlg（"没有可以发送文件的用户存在！", mtError, [mbOK], 0）;
204.end;
205.end;
206.
207.procedure TMainForm.FormCreate（Sender: TObject）;
208.begin
209.FormHanlde := Self.Handle;
210.FUsers := TThreadList.Create;
211.FLockUI := TCriticalSection.Create;
212.with IdTCPServer.Bindings.Add do
213.begin
214.IP := IdIPWatch.LocalIP;
215.Port := 3030;
216.end;
217.IdTCPServer.Active := True;
218.end;
219.
220.procedure TMainForm.FormClose（Sender: TObject; var Action: TCloseAction）;
221.begin
222.FormHanlde := 0;
223.if IdTCPServer.Active then IdTCPServer.Active := False;
224.ClearUsers;
225.FUsers.Free;
226.FLockUI.Free;
227.end;
228.
229.procedure TMainForm.ClearUsers;
230.var
231.lst: TList;
232.I: Integer;
233.User: TUser;
234.begin
235.lst := FUsers.LockList;
236.try
237.for I := 0 to lst.Count - 1 do
238.begin
239.User := lst[I];
240.if User <> nil then User.Context := nil;
241.User.Free;
242.end;
243.FUsers.Clear;
244.finally
245.FUsers.UnlockList;
246.end;
247.end;
248.
249.procedure TMainForm.IdTCPServerConnect（AContext: TIdContext）;
250.var
251.Client: TUser;
252.AUserName: string;
253.lst: TList;
254.I: Integer;
255.begin
256.AUserName := AContext.Connection.IOHandler.ReadLn;
257.if AUserName = "" then
258.begin
259.AContext.Connection.IOHandler.WriteLn（"NO_USER_NAME"）;
260.AContext.Connection.Disconnect;
261.Exit;
262.end;
263.lst := FUsers.LockList;
264.try
265.for I := 0 to lst.Count - 1 do
266.if SameText（TUser（lst[I]）.UserName, AUserName） then
267.begin
268.AContext.Connection.IOHandler.WriteLn（"USER_ALREADY_LOGINED"）;
269.AContext.Connection.Disconnect;
270.Exit;
271.end;
272.
273.Client := TUser.Create（AContext.Binding.PeerIP, AUserName,
274.AContext.Binding.PeerPort, AContext）;
275.lst.Add（Client）;
276.Client.Lock;
277.try
278.Client.Context.Connection.IOHandler.WriteLn（"LOGINED"）;
279.finally
280.Client.Unlock;
281.end;
282.finally
283.FUsers.UnlockList;
284.end;
285.SendMessage（FormHanlde, WM_REFRESH_USERS, Ord（rpAppendItem）, Integer（Client））;
286.end;
287.
288.procedure TMainForm.IdTCPServerDisconnect（AContext: TIdContext）;
289.var
290.Client: TUser;
291.begin
292.Client := TUser（AContext.Data）;
293.if Client <> nil then
294.begin
295.Client.Lock;
296.try
297.Client.Context := nil;
298.finally
299.Client.Unlock;
300.end;
301.
302.FUsers.Remove（Client）;
303.SendMessage（FormHanlde, WM_REFRESH_USERS, Ord（rpDeleteItem）, Integer（Client））;
304.Client.Free;
305.end;
306.end;
307.
308.procedure TMainForm.IdTCPServerExecute（AContext: TIdContext）;
309.var
310.Client: TUser;
311.Msg, Cmd: string;
312.cmds: TList;
313.CmdRec: PCmdRec;
314.begin
315.Client := TUser（AContext.Data）;
316.if Client <> nil then
317.begin
318.Client.Lock;
319.try
320.AContext.Connection.IOHandler.CheckForDataOnSource（250）;
321.if not AContext.Connection.IOHandler.InputBufferIsEmpty then
322.begin
323.Msg := AContext.Connection.IOHandler.ReadLn（enUTF8）;
324.if FormHanlde <> 0 then
325.begin
326.LockUI;
327.try
328.Memo1.Lines.Add（Format（"IP: %s 的 %s 用户说："%s"", [Client.IP, Client.UserName, Msg]））;
329.finally
330.UnlockUI;
331.end;
332.end;
333.end;
334.
335.cmds := Client.CommandQueues.LockList;
336.try
337.if cmds.Count > 0 then
338.begin
339.CmdRec := cmds[0];
340.Cmd := CmdRec.Cmd;
341.cmds.Delete（0）;
342.Dispose（CmdRec）;
343.end
344.else Cmd := "";
345.finally
346.Client.CommandQueues.UnlockList;
347.end;
348.
349.if Cmd = "" then Exit;
350.if Pos（"SENDF", Cmd） = 1 then
351.begin
352.if FormHanlde <> 0 then
353.begin
354.LockUI;
355.try
356.Memo1.Lines.Add（Format（"发送文件到 %s（IP: %s）", [Client.UserName, CLient.IP]））;
357.finally
358.UnlockUI;
359.end;
360.end;
361.SendFileToUser（Client, Trim（Copy（Cmd, 6, Length（Cmd））））;
362.end
363.else if Pos（"SENDT", Cmd） = 1 then
364.begin
365.if FormHanlde <> 0 then
366.begin
367.LockUI;
368.try
369.Memo1.Lines.Add（Format（"发送文本信息到 %s（IP: %s），文本内容: "%s"", [Client.UserName, Client.IP, Trim（Copy（Cmd, 6, Length（Cmd）））]））;
370.finally
371.UnlockUI;
372.end;
373.end;
374.SendTextToUser（Client, Trim（Copy（Cmd, 6, Length（Cmd））））;
375.end;
376.finally
377.Client.Unlock;
378.end;
379.end;
380.end;
381.
382.procedure TMainForm.SendFileToUser（AUser: TUser; const FileName: string）;
383.var
384.FStream: TFileStream;
385.Str: string;
386.begin
387.if AUser.Context <> nil then
388.with AUser.Context do
389.begin
390.Connection.IOHandler.WriteLn（Format（"FILE %s", [ExtractFileName（FileName）]））;
391.Str := Connection.IOHandler.ReadLn;
392.if SameText（Str, "SIZE"） then
393.begin
394.FStream := TFileStream.Create（FileName, fmOpenRead or
395.fmShareDenyWrite）;
396.try
397.Connection.IOHandler.Write（ToBytes（FStream.Size））;
398.Str := Connection.IOHandler.ReadLn;
399.if SameText（Str, "READY"） then
400.begin
401.Connection.IOHandler.LargeStream := True;
402.Connection.OnWork := AUser.DoWork;
403.AUser.FWorkSize := FStream.Size;
404.Connection.IOHandler.Write（FStream, FStream.Size）;
405.Connection.OnWork := nil;
406.Connection.IOHandler.LargeStream := False;
407.Str := Connection.IOHandler.ReadLn;
408.if FormHanlde <> 0 then
409.begin
410.LockUI;
411.try
412.if SameText（Str, "OK"） then
413.Memo1.Lines.Add（Format（"用户: %s （IP: %s）已成功接收文件。", [AUser.UserName, AUser.IP]））
414.else
415.Memo1.Lines.Add（Format（"传输终止！用户： %s ，IP: %s", [AUser.UserName, AUser.IP]））;
416.finally
417.UnlockUI;
418.end;
419.end;
420.Connection.IOHandler.WriteLn（"DONE"）;
421.end;
422.finally
423.FStream.Free;
424.end;
425.end;
426.end;
427.end;
428.
429.procedure TMainForm.WMRefreshUsers（var Msg: TMessage）;
430.begin
431.if Msg.Msg = WM_REFRESH_USERS then
432.begin
433.case TRefreshParam（Msg.WParam） of
434.rpRefreshAll: begin
435.RefreshUsersInListView;
436.end;
437.rpAppendItem: begin
438.AddUserInListView（TUser（Msg.LParam））;
439.end;
440.rpDeleteItem: begin
441.DeleteUserInListView（TUser（Msg.LParam））;
442.end;
443.end;
444.end;
445.end;
446.
447.procedure TMainForm.DeleteUserInListView（AClient: TUser）;
448.begin
449.if AClient.ListItem <> nil then
450.AClient.ListItem.Delete;
451.end;
452.
453.procedure TMainForm.edtMsgKeyDown（Sender: TObject; var Key: Word; Shift:
454.TShiftState）;
455.var
456.I: Integer;
457.Client: TUser;
458.cmds: TList;
459.CmdRec: PCmdRec;
460.begin
461.if Key = VK_RETURN then
462.begin
463.lvUsers.Enabled := False;
464.try
465.for I := 0 to lvUsers.Items.Count - 1 do
466.begin
467.if I = 0 then Memo1.Lines.Add（""）;
468.if lvUsers.Items[I].Checked then
469.begin
470.Client := TUser（lvUsers.Items[I].Data）;
471.if Client <> nil then
472.begin
473.cmds := Client.CommandQueues.LockList;
474.try
475.New（CmdRec）;
476.CmdRec^.Cmd := Format（"SENDT %s", [edtMsg.Text]）;
477.cmds.Add（CmdRec）;
478.finally
479.Client.CommandQueues.UnlockList;
480.end;
481.end;
482.end;
483.end;
484.edtMsg.Clear;
485.finally
486.lvUsers.Enabled := True;
487.end;
488.Key := 0;
489.end;
490.end;
491.
492.procedure TMainForm.RefreshUsersInListView;
493.var
494.lst: TList;
495.I: Integer;
496.begin
497.lvUsers.Items.BeginUpdate;
498.try
499.lvUsers.Clear;
500.lst := FUsers.LockList;
501.try
502.for I := 0 to lst.Count - 1 do
503.SendMessage（FormHanlde, WM_REFRESH_USERS, Ord（rpAppendItem）,
504.Integer（lst[I]））;
505.finally
506.FUsers.UnlockList;
507.end;
508.finally
509.lvUsers.Items.EndUpdate;
510.end;
511.end;
512.
513.procedure TMainForm.LockUI;
514.begin
515.FLockUI.Enter;
516.end;
517.
518.procedure TMainForm.UnlockUI;
519.begin
520.FLockUI.Leave;
521.end;
522.
523.procedure TMainForm.SendTextToUser（AUser: TUSer; const Text: string）;
524.begin
525.if AUser.Context <> nil then
526.with AUser.Context do
527.begin
528.Connection.IOHandler.WriteLn（Text, enUTF8）;
529.end;
530.end;
531.
532.procedure TMainForm.AddUserInListView（AClient: TUser）;
533.var
534.Item: TListItem;
535.begin
536.Item := lvUsers.Items.Add;
537.Item.Caption := AClient.UserName;
538.AClient.ListItem := Item;
539.Item.SubItems.Add（Format（"%s[%d]", [AClient.IP, AClient.Port]））;
540.Item.SubItems.Add（"N/A"）;
541.Item.Checked := AClient.Selected;
542.end;
543.
544.procedure TMainForm.lvUsersChange（Sender: TObject; Item: TListItem; Change:
545.TItemChange）;
546.begin
547.if （Change = ctState） and （Item.Data <> nil） then
548.TUser（Item.Data）.Selected := Item.Checked;
549.end;
550.
551.procedure TMainForm.miClearLogClick（Sender: TObject）;
552.begin
553.LockUI;
554.try
555.Memo1.Lines.Clear;
556.finally
557.UnlockUI;
558.end;
559.end;
560.
561.procedure TMainForm.mmiRefreshClick（Sender: TObject）;
562.begin
563.SendMessage（FormHanlde, WM_REFRESH_USERS, Ord（rpRefreshAll）, 0）;
564.end;
565.
566.end.