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

代码如下:
  1. unit Unit1;
  2. interface
  3. uses
  4.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  5.   Dialogs, IdBaseComponent, IdComponent, IdGlobal, IdTCPConnection, IdTCPClient,
  6.   ExtCtrls, StdCtrls, ComCtrls, XPMan;
  7. type
  8.   TForm1 = class(TForm)
  9.     IdTCPClient: TIdTCPClient;
  10.     btnConnect: TButton;
  11.     tmrCheckServerMsg: TTimer;
  12.     btnDisconect: TButton;
  13.     edtMsg: TEdit;
  14.     pbProgress: TProgressBar;
  15.     mmoInfo: TMemo;
  16.     XPManifest1: TXPManifest;
  17.     procedure btnConnectClick(Sender: TObject);
  18.     procedure btnDisconectClick(Sender: TObject);
  19.     procedure edtMsgKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  20.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  21.     procedure FormCreate(Sender: TObject);
  22.     procedure FormShow(Sender: TObject);
  23.     procedure IdTCPClientWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
  24.     procedure tmrCheckServerMsgTimer(Sender: TObject);
  25.   private
  26.     { Private declarations }
  27.   public
  28.     { Public declarations }
  29.   end;
  30. var
  31.   Form1: TForm1;
  32. implementation
  33. uses TypInfo;
  34. {$R *.dfm}
  35. procedure TForm1.btnConnectClick(Sender: TObject);
  36. var
  37.   Response: string;
  38.   UserName: string;
  39.   HostName: array[0..MAX_COMPUTERNAME_LENGTH] of char;
  40.   Length: DWORD;
  41. begin
  42.   IdTCPClient.ConnectTimeout := 5000;
  43.   IdTCPClient.Connect;
  44.   //UserName := Format('U%.5d', [Random(99999)]);
  45.   Length := SizeOf(HostName);
  46.   GetComputerName(HostName, Length);
  47.   UserName := HostName;
  48.   IdTCPClient.IOHandler.WriteLn(UserName);
  49.   Response := IdTCPClient.IOHandler.ReadLn;
  50.   if SameText(Response, 'LOGINED') then
  51.   begin
  52.     btnDisconect.Enabled := True;
  53.     btnConnect.Enabled := False;
  54.     tmrCheckServerMsg.Enabled := True;
  55.     Caption := 'Client - ' + UserName;
  56.   end
  57.   else raise Exception.CreateFmt('登录失败: "%s"', [Response]);
  58. end;
  59. procedure TForm1.btnDisconectClick(Sender: TObject);
  60. begin
  61.   btnConnect.Enabled := True;
  62.   btnDisconect.Enabled := False;
  63.   tmrCheckServerMsg.Enabled := False;
  64.   Caption := 'Client';
  65.   IdTCPClient.Disconnect;
  66. end;
  67. procedure TForm1.edtMsgKeyDown(Sender: TObject; var Key: Word; Shift:
  68.   TShiftState);
  69. begin
  70.   if Key = VK_RETURN then
  71.   begin
  72.     if not IdTCPClient.Connected then Exit;
  73.     if edtMsg.Text <> '' then
  74.     begin
  75.       IdTCPClient.IOHandler.WriteLn(edtMsg.Text, enUTF8);
  76.       mmoInfo.Lines.Add(Format('发送消息: "%s"', [edtMsg.Text]));
  77.       edtMsg.Clear;
  78.     end;
  79.     Key := 0;
  80.   end;
  81. end;
  82. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
  83. begin
  84.   try
  85.     if IdTCPClient.Connected then
  86.       btnDisconect.Click;
  87.   except
  88.   end;
  89. end;
  90. procedure TForm1.FormCreate(Sender: TObject);
  91. begin
  92.   Randomize;
  93.   IdTCPClient.Host := '192.168.2.148';
  94.   IdTCPClient.Port := 3030;
  95. end;
  96. procedure TForm1.FormShow(Sender: TObject);
  97. begin
  98.   btnConnect.Click;
  99. end;
  100. procedure TForm1.IdTCPClientWork(ASender: TObject; AWorkMode: TWorkMode;
  101.   AWorkCount: Int64);
  102. begin
  103.   pbProgress.Position := AWorkCount;
  104.   Application.ProcessMessages;
  105. end;
  106. type
  107.   TSizeType = (stB, stK, stM, stG, stT);
  108. function FormatFileSize(Size: Extended; MaxSizeType: TSizeType; var ReturnSizeType: TSizeType;
  109.   const IncludeComma: Boolean = True): string; overload;
  110. const
  111.   FormatStr: array[Boolean] of string = ('0.##''#,##0.##'); {do not localize}
  112. var
  113.   DivCount: Integer;
  114. begin
  115.   ReturnSizeType := stB;
  116.   DivCount := 0;
  117.   while (Size >= 1024) and (ReturnSizeType <> MaxSizeType) do
  118.   begin
  119.     Size := Size / 1024;
  120.     Inc(DivCount);
  121.     case DivCount of
  122.       1: ReturnSizeType := stK;
  123.       2: ReturnSizeType := stM;
  124.       3: ReturnSizeType := stG;
  125.       4: ReturnSizeType := stT;
  126.     end;
  127.   end;
  128.   Result := FormatFloat(FormatStr[IncludeComma], Size);
  129. end;
  130. function FormatFileSize(Size: Extended; MaxSizeType: TSizeType;
  131.   const IncludeComma: Boolean = True): string; overload;
  132. resourcestring
  133.   RSC_BYTE = '字节';
  134. var
  135.   ReturnSt: TSizeType;
  136. begin
  137.   Result := FormatFileSize(Size, stT, ReturnSt, True) + ' ' +
  138.     Copy(GetEnumName(TypeInfo(TSizeType), Ord(ReturnSt)), 3, 1);
  139.   if ReturnSt = stB then
  140.   begin
  141.     Delete(Result, Length(Result), 1);
  142.     Result := Result + RSC_BYTE;
  143.   end
  144.   else
  145.     Result := Result + 'B'; {do not localize}
  146. end;
  147. procedure TForm1.tmrCheckServerMsgTimer(Sender: TObject);
  148. var
  149.   CmdStr: string;
  150.   FSize: Int64;
  151.   FStream: TFileStream;
  152.   SaveFileName: string;
  153. begin
  154.   CmdStr := '';
  155.   if IdTCPClient.Connected then
  156.   begin
  157.     IdTCPClient.IOHandler.CheckForDataOnSource(250);
  158.     if not IdTCPClient.IOHandler.InputBufferIsEmpty then
  159.     begin
  160.       tmrCheckServerMsg.Enabled := False;
  161.       try
  162.         CmdStr := IdTCPClient.IOHandler.ReadLn(enUTF8);
  163.         CmdStr := System.UTF8Encode(CmdStr);
  164.         if SameText(Copy(CmdStr, 1, 4), 'FILE') then
  165.         begin
  166.           SaveFileName := Trim(Copy(CmdStr, 5, Length(CmdStr)));
  167.           mmoInfo.Lines.Add('准备接收文件....');
  168.           IdTCPClient.IOHandler.WriteLn('SIZE');
  169.           FSize :=IdTCPClient.IOHandler.ReadInt64(False);
  170.           if FSize > 0 then
  171.           begin
  172.             pbProgress.Max := FSize;
  173.             pbProgress.Position := 0;
  174.             mmoInfo.Lines.Add('文件大小 =' + FormatFileSize(FSize, stK) + '; 正在接收中...');
  175.             IdTCPClient.IOHandler.WriteLn('READY');
  176.             while True do
  177.             begin
  178.               if FileExists(ExtractFilePath(ParamStr(0)) + SaveFileName) then
  179.                  SaveFileName := '~' + SaveFileName
  180.               else Break;
  181.             end;
  182.             FStream := TFileStream.Create(ExtractFilePath(ParamStr(0))
  183.               + SaveFileName,
  184.               fmCreate);
  185.             try
  186.               IdTCPClient.IOHandler.LargeStream := True;
  187.               IdTCPClient.IOHandler.ReadStream(FStream, FSize);
  188.               IdTCPClient.IOHandler.LargeStream := False;
  189.               IdTCPClient.IOHandler.WriteLn('OK');
  190.               if IdTCPClient.IOHandler.ReadLn = 'DONE' then
  191.                 mmoInfo.Lines.Add('接收成功!')
  192.             finally
  193.               FStream.Free;
  194.             end;
  195.           end
  196.           else begin
  197.             mmoInfo.Lines.Add('接收失败!');
  198.             IdTCPClient.IOHandler.WriteLn('CANCEL');
  199.           end;
  200.         end
  201.         else
  202.           mmoInfo.Lines.Add('接收文本信息: ' + CmdStr)
  203.       finally
  204.         tmrCheckServerMsg.Enabled := True;
  205.       end;
  206.     end;
  207.   end;
  208. end;
  209. end.
  • 0
    点赞
  • 3
    收藏
    觉得还不错? 一键收藏
  • 1
    评论
Delphi 7是一种集成开发环境(IDE),经常用于创建Windows应用程序。而Indy是一个Delphi中的开源组件库,用于网络编程。 HTTPS(Hypertext Transfer Protocol Secure)是一种安全的HTTP通信协议,它通过使用SSL/TLS协议来改进数据传输的安全性。Indy组件库提供了处理HTTPS通信的功能,使得在Delphi 7中实现HTTPS通信变得相对简单。 要在Delphi 7中使用Indy组件来实现HTTPS,首先需要将Indy组件库添加到Delphi项目中。这可以通过设置Delphi的搜索路径,或手动将相应的包文件添加到项目中来完成。添加完成后,在Delphi的组件面板中可以看到Indy相关的组件。 在项目中,我们可以使用TIdHTTP组件进行HTTPS通信。TIdHTTP是Indy组件库提供的用于HTTP和HTTPS通信的组件。我们需要设置TIdHTTP组件的一些属性,例如URL地址、如果需要的话设置代理服务器等。 接下来,我们可以使用TIdHTTP组件提供的方法来发送HTTP请求,例如GET或POST请求。对于HTTPS,我们需要设置一些额外的属性,例如SSL版本、证书等。 当我们发送HTTPS请求后,服务器将使用SSL/TLS协议来对数据进行加密和认证。在使用TIdHTTP组件时,Indy会自动处理SSL/TLS握手和证书验证等操作,使得我们无需关心这些细节。 最后,我们可以通过解析返回的HTTP响应来获取服务器返回的数据。可以使用TIdHTTP组件提供的方法来获取响应的内容。 总的来说,通过Delphi 7和Indy组件,我们可以方便地实现HTTPS通信功能。利用Indy提供的TIdHTTP组件,我们可以发送HTTPS请求,并获取服务器返回的数据。Delphi 7和Indy的组合为我们提供了一种简单而可靠的方式来开发安全的网络应用程序。

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论 1
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值