Delphi2009的Indy全接触之TCP篇

来源：互联网发布：java timer用法编辑：程序博客网时间：2024/05/29 19:37

我在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
代码如下：

unit Unit1;
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;
    procedure SetContext(const Value: TIdContext);
    procedure SetListItem(const Value: TListItem);
  protected
    procedure DoWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
  public
    constructor Create(const AIP, AUserName: string; APort: Integer; AContext: TIdContext); reintroduce;
    destructor Destroy; override;
    procedure Lock;
    procedure Unlock;
    property IP: string read FIP;
    property Port: Integer read FPort;
    property UserName: string read FUserName;
    property Selected: Boolean read FSelected write FSelected;
    property Context: TIdContext read FContext write SetContext;
    property CommandQueues: TThreadList read FCommandQueues;
    property ListItem: TListItem read FListItem write SetListItem;
  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;
    procedure btnSendFileToClientClick(Sender: TObject);
    procedure edtMsgKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure IdTCPServerConnect(AContext: TIdContext);
    procedure IdTCPServerDisconnect(AContext: TIdContext);
    procedure IdTCPServerExecute(AContext: TIdContext);
    procedure lvUsersChange(Sender: TObject; Item: TListItem; Change: TItemChange);
    procedure miClearLogClick(Sender: TObject);
    procedure mmiRefreshClick(Sender: TObject);
  private
    { Private declarations }
    FUsers: TThreadList;
    FLockUI: TCriticalSection;
    procedure ClearUsers;
    procedure RefreshUsersInListView;
    procedure DeleteUserInListView(AClient: TUser);
    procedure AddUserInListView(AClient: TUser);
    procedure SendFileToUser(AUser: TUser; const FileName: string);
    procedure SendTextToUser(AUser: TUSer; const Text: string);
    procedure LockUI;
    procedure UnlockUI;
    procedure WMRefreshUsers(var Msg: TMessage); message WM_REFRESH_USERS;
  public
    { Public declarations }
  end;
var
  MainForm: TMainForm;
implementation
{$R *.dfm}
{ TUser }
constructor TUser.Create(const AIP, AUserName: string; APort: Integer; AContext: TIdContext);
begin
  FLock := TCriticalSection.Create;
  FIP := AIP;
  FPort := APort;
  FUserName := AUserName;
  Context := AContext;
  FCommandQueues := TThreadList.Create;
end;
destructor TUser.Destroy;
begin
  FCommandQueues.Free;
  FLock.Free;
  inherited;
end;
procedure TUser.SetContext(const Value: TIdContext);
begin
  if FContext <> nil then FContext.Data := nil;
  if Value <> nil then Value.Data := Self;
  FContext := Value;
end;
procedure TUser.Lock;
begin
  FLock.Enter;
end;
procedure TUser.Unlock;
begin
  FLock.Leave;
end;
procedure TUser.SetListItem(const Value: TListItem);
begin
  if FListItem <> Value then
    FListItem := Value;
  if Value <> nil then Value.Data := Self;
end;
function GetPercentFrom(Int, Total: Int64): Double;
begin
  if (Int = 0) or (Total = 0) then
    Result := 0
  else if Int = Total then
    Result := 100
  else begin
    Result := Int / (Total / 100);
  end;
end;
procedure TUser.DoWork(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
var
  NewPercent: string;
begin
  if ListItem <> nil then
  begin
    NewPercent := IntToStr(Trunc(GetPercentFrom(AWorkCount,
      FWorkSize))) + '%';
    if ListItem.SubItems[1] <> NewPercent then ListItem.SubItems[1] := NewPercent;
  end;
end;
{ TForm1 }
var
  FormHanlde: HWND = 0;
procedure TMainForm.btnSendFileToClientClick(Sender: TObject);
var
  I: Integer;
  Client: TUser;
  cmds: TList;
  CmdRec: PCmdRec;
  SendUserCount: Integer;
begin
  if dlgOpenSendingFile.Execute then
  begin
    lvUsers.Enabled := False;
    try
      SendUserCount := 0;
      for I := 0 to lvUsers.Items.Count - 1 do
        if lvUsers.Items[I].Checked then
        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;
    if SendUserCount <= 0 then
      MessageDlg('没有可以发送文件的用户存在！', mtError, [mbOK], 0);
  end;
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
  FormHanlde := Self.Handle;
  FUsers := TThreadList.Create;
  FLockUI := TCriticalSection.Create;
  with IdTCPServer.Bindings.Add do
  begin
    IP := IdIPWatch.LocalIP;
    Port := 3030;
  end;
  IdTCPServer.Active := True;
end;
procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FormHanlde := 0;
  if IdTCPServer.Active then IdTCPServer.Active := False;
  ClearUsers;
  FUsers.Free;
  FLockUI.Free;
end;
procedure TMainForm.ClearUsers;
var
  lst: TList;
  I: Integer;
  User: TUser;
begin
  lst := FUsers.LockList;
  try
    for I := 0 to lst.Count - 1 do
    begin
      User := lst[I];
      if User <> nil then User.Context := nil;
      User.Free;
    end;
    FUsers.Clear;
  finally
    FUsers.UnlockList;
  end;
end;
procedure TMainForm.IdTCPServerConnect(AContext: TIdContext);
var
  Client: TUser;
  AUserName: string;
  lst: TList;
  I: Integer;
begin
  AUserName := AContext.Connection.IOHandler.ReadLn;
  if AUserName = '' then
  begin
    AContext.Connection.IOHandler.WriteLn('NO_USER_NAME');
    AContext.Connection.Disconnect;
    Exit;
  end;
  lst := FUsers.LockList;
  try
    for I := 0 to lst.Count - 1 do
      if SameText(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;
procedure TMainForm.IdTCPServerDisconnect(AContext: TIdContext);
var
  Client: TUser;
begin
  Client := TUser(AContext.Data);
  if Client <> nil then
  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;
procedure TMainForm.IdTCPServerExecute(AContext: TIdContext);
var
  Client: TUser;
  Msg, Cmd: string;
  cmds: TList;
  CmdRec: PCmdRec;
begin
  Client := TUser(AContext.Data);
  if Client <> nil then
  begin
    Client.Lock;
    try
      AContext.Connection.IOHandler.CheckForDataOnSource(250);
      if not AContext.Connection.IOHandler.InputBufferIsEmpty then
      begin
        Msg := AContext.Connection.IOHandler.ReadLn(enUTF8);
        if FormHanlde <> 0 then
        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
        if cmds.Count > 0 then
        begin
          CmdRec := cmds[0];
          Cmd := CmdRec.Cmd;
          cmds.Delete(0);
          Dispose(CmdRec);
        end
        else Cmd := '';
      finally
        Client.CommandQueues.UnlockList;
      end;
      if Cmd = '' then Exit;
      if Pos('SENDF', Cmd) = 1 then
      begin
        if FormHanlde <> 0 then
        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
      else if Pos('SENDT', Cmd) = 1 then
      begin
        if FormHanlde <> 0 then
        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;
procedure TMainForm.SendFileToUser(AUser: TUser; const FileName: string);
var
  FStream: TFileStream;
  Str: string;
begin
  if AUser.Context <> nil then
    with AUser.Context do
    begin
      Connection.IOHandler.WriteLn(Format('FILE %s', [ExtractFileName(FileName)]));
      Str := Connection.IOHandler.ReadLn;
      if SameText(Str, 'SIZE') then
      begin
        FStream := TFileStream.Create(FileName, fmOpenRead or
          fmShareDenyWrite);
        try
          Connection.IOHandler.Write(ToBytes(FStream.Size));
          Str := Connection.IOHandler.ReadLn;
          if SameText(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;
            if FormHanlde <> 0 then
            begin
              LockUI;
              try
                if SameText(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;
procedure TMainForm.WMRefreshUsers(var Msg: TMessage);
begin
  if Msg.Msg = WM_REFRESH_USERS then
  begin
    case TRefreshParam(Msg.WParam) of
      rpRefreshAll: begin
          RefreshUsersInListView;
        end;
      rpAppendItem: begin
          AddUserInListView(TUser(Msg.LParam));
        end;
      rpDeleteItem: begin
          DeleteUserInListView(TUser(Msg.LParam));
        end;
    end;
  end;
end;
procedure TMainForm.DeleteUserInListView(AClient: TUser);
begin
  if AClient.ListItem <> nil then
    AClient.ListItem.Delete;
end;
procedure TMainForm.edtMsgKeyDown(Sender: TObject; var Key: Word; Shift:
  TShiftState);
var
  I: Integer;
  Client: TUser;
  cmds: TList;
  CmdRec: PCmdRec;
begin
  if Key = VK_RETURN then
  begin
    lvUsers.Enabled := False;
    try
      for I := 0 to lvUsers.Items.Count - 1 do
      begin
        if I = 0 then Memo1.Lines.Add('');
        if lvUsers.Items[I].Checked then
        begin
          Client := TUser(lvUsers.Items[I].Data);
          if Client <> nil then
          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;
procedure TMainForm.RefreshUsersInListView;
var
  lst: TList;
  I: Integer;
begin
  lvUsers.Items.BeginUpdate;
  try
    lvUsers.Clear;
    lst := FUsers.LockList;
    try
      for I := 0 to lst.Count - 1 do
        SendMessage(FormHanlde, WM_REFRESH_USERS, Ord(rpAppendItem),
          Integer(lst[I]));
    finally
      FUsers.UnlockList;
    end;
  finally
    lvUsers.Items.EndUpdate;
  end;
end;
procedure TMainForm.LockUI;
begin
  FLockUI.Enter;
end;
procedure TMainForm.UnlockUI;
begin
  FLockUI.Leave;
end;
procedure TMainForm.SendTextToUser(AUser: TUSer; const Text: string);
begin
  if AUser.Context <> nil then
    with AUser.Context do
    begin
      Connection.IOHandler.WriteLn(Text, enUTF8);
    end;
end;
procedure TMainForm.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;
procedure TMainForm.lvUsersChange(Sender: TObject; Item: TListItem; Change:
    TItemChange);
begin
  if (Change = ctState) and (Item.Data <> nil) then
    TUser(Item.Data).Selected := Item.Checked;
end;
procedure TMainForm.miClearLogClick(Sender: TObject);
begin
  LockUI;
  try
    Memo1.Lines.Clear;
  finally
    UnlockUI;
  end;
end;
procedure TMainForm.mmiRefreshClick(Sender: TObject);
begin
  SendMessage(FormHanlde, WM_REFRESH_USERS, Ord(rpRefreshAll), 0);
end;
end.

然后是客户端：

代码如下：

unit Unit1;
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;
    procedure btnConnectClick(Sender: TObject);
    procedure btnDisconectClick(Sender: TObject);
    procedure edtMsgKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure IdTCPClientWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
    procedure tmrCheckServerMsgTimer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
uses TypInfo;
{$R *.dfm}
procedure TForm1.btnConnectClick(Sender: TObject);
var
  Response: string;
  UserName: string;
  HostName: array[0..MAX_COMPUTERNAME_LENGTH] of char;
  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;
  if SameText(Response, 'LOGINED') then
  begin
    btnDisconect.Enabled := True;
    btnConnect.Enabled := False;
    tmrCheckServerMsg.Enabled := True;
    Caption := 'Client - ' + UserName;
  end
  else raise Exception.CreateFmt('登录失败: "%s"', [Response]);
end;
procedure TForm1.btnDisconectClick(Sender: TObject);
begin
  btnConnect.Enabled := True;
  btnDisconect.Enabled := False;
  tmrCheckServerMsg.Enabled := False;
  Caption := 'Client';
  IdTCPClient.Disconnect;
end;
procedure TForm1.edtMsgKeyDown(Sender: TObject; var Key: Word; Shift:
  TShiftState);
begin
  if Key = VK_RETURN then
  begin
    if not IdTCPClient.Connected then Exit;
    if edtMsg.Text <> '' then
    begin
      IdTCPClient.IOHandler.WriteLn(edtMsg.Text, enUTF8);
      mmoInfo.Lines.Add(Format('发送消息: "%s"', [edtMsg.Text]));
      edtMsg.Clear;
    end;
    Key := 0;
  end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  try
    if IdTCPClient.Connected then
      btnDisconect.Click;
  except
  end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  Randomize;
  IdTCPClient.Host := '192.168.2.148';
  IdTCPClient.Port := 3030;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
  btnConnect.Click;
end;
procedure TForm1.IdTCPClientWork(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
begin
  pbProgress.Position := AWorkCount;
  Application.ProcessMessages;
end;
type
  TSizeType = (stB, stK, stM, stG, stT);
function FormatFileSize(Size: Extended; MaxSizeType: TSizeType; var ReturnSizeType: TSizeType;
  const IncludeComma: Boolean = True): string; overload;
const
  FormatStr: array[Boolean] of string = ('0.##', '#,##0.##'); {do not localize}
var
  DivCount: Integer;
begin
  ReturnSizeType := stB;
  DivCount := 0;
  while (Size >= 1024) and (ReturnSizeType <> MaxSizeType) do
  begin
    Size := Size / 1024;
    Inc(DivCount);
    case DivCount of
      1: ReturnSizeType := stK;
      2: ReturnSizeType := stM;
      3: ReturnSizeType := stG;
      4: ReturnSizeType := stT;
    end;
  end;
  Result := FormatFloat(FormatStr[IncludeComma], Size);
end;
function FormatFileSize(Size: Extended; MaxSizeType: TSizeType;
  const IncludeComma: 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);
  if ReturnSt = stB then
  begin
    Delete(Result, Length(Result), 1);
    Result := Result + RSC_BYTE;
  end
  else
    Result := Result + 'B'; {do not localize}
end;
procedure TForm1.tmrCheckServerMsgTimer(Sender: TObject);
var
  CmdStr: string;
  FSize: Int64;
  FStream: TFileStream;
  SaveFileName: string;
begin
  CmdStr := '';
  if IdTCPClient.Connected then
  begin
    IdTCPClient.IOHandler.CheckForDataOnSource(250);
    if not IdTCPClient.IOHandler.InputBufferIsEmpty then
    begin
      tmrCheckServerMsg.Enabled := False;
      try
        CmdStr := IdTCPClient.IOHandler.ReadLn(enUTF8);
        CmdStr := System.UTF8Encode(CmdStr);
        if SameText(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);
          if FSize > 0 then
          begin
            pbProgress.Max := FSize;
            pbProgress.Position := 0;
            mmoInfo.Lines.Add('文件大小 =' + FormatFileSize(FSize, stK) + '; 正在接收中...');
            IdTCPClient.IOHandler.WriteLn('READY');
            while True do
            begin
              if FileExists(ExtractFilePath(ParamStr(0)) + SaveFileName) then
                 SaveFileName := '~' + SaveFileName
              else Break;
            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');
              if IdTCPClient.IOHandler.ReadLn = 'DONE' then
                mmoInfo.Lines.Add('接收成功！')
            finally
              FStream.Free;
            end;
          end
          else begin
            mmoInfo.Lines.Add('接收失败！');
            IdTCPClient.IOHandler.WriteLn('CANCEL');
          end;
        end
        else
          mmoInfo.Lines.Add('接收文本信息: ' + CmdStr)
      finally
        tmrCheckServerMsg.Enabled := True;
      end;
    end;
  end;
end;
end.