unit1.pas

用delphi的现有控件写的一个简单的发送文件客户端

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, IdBaseComponent, IdComponent,
  IdCustomTCPServer, IdTCPServer, IdGlobal, IdException, IdContext,
  AppEvnts;

type
  TForm1 = class(TForm)
    btnActiveServer: TButton;
    btnClose: TButton;
    redtLog: TRichEdit;
    IdTCPServer: TIdTCPServer;
    ApplicationEvents: TApplicationEvents;
    procedure btnActiveServerClick(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure ApplicationEventsException(Sender: TObject; E: Exception);
    procedure IdTCPServerExecute(AContext: TIdContext);
    procedure IdTCPServerException(AContext: TIdContext;
      AException: Exception);
    procedure IdTCPServerConnect(AContext: TIdContext);
    procedure IdTCPServerDisconnect(AContext: TIdContext);
  private
    { Private declarations }
    FSection: TRTLCriticalSection;
    procedure LockUI;
    procedure UnlockUI;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure LogInfo(const LogText: string; LineColor: TColor = clBlack;
      ThreadMode: Boolean = True);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }

procedure TForm1.LogInfo(const LogText: string; LineColor: TColor = clBlack;
  ThreadMode: Boolean = True);
begin
  if ThreadMode then LockUI;
  try
    with redtLog do
    begin
      SelAttributes.Color := LineColor;
      Lines.Append(Format('[%s]:%s', [DateTimeToStr(Now), LogText]));
    end;
  finally
    if ThreadMode then UnlockUI;
  end;
end;

procedure TForm1.btnActiveServerClick(Sender: TObject);

  procedure DisplayActiveStatusOnActiveButton;
  begin
    case IdTCPServer.Active of
      True: btnActiveServer.Caption := 'Diactive';
      False: btnActiveServer.Caption := 'Active';
    end;
  end;

begin
  try
    IdTCPServer.Active := not IdTCPServer.Active;
    DisplayActiveStatusOnActiveButton;
    case IdTCPServer.Active of
      True: LogInfo('Active Server.', clBlue, False);
      False: LogInfo('Close Server', clBlue, False);
    end;
  except
    on E: EIdConnClosedGracefully do
    begin
      DisplayActiveStatusOnActiveButton;
      raise;
    end
  else
    raise;
  end;
end;

procedure TForm1.btnCloseClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.ApplicationEventsException(Sender: TObject; E: Exception);
begin
  LogInfo(E.Message, clRed);
end;

procedure TForm1.IdTCPServerExecute(AContext: TIdContext);
var
  PIP: string;
  s: string;
  SaveFileName: string;
  FileStream: TFileStream;
  Size: Int64;
begin
  if AContext.Connection.Connected then
  begin
    PIP := AContext.Binding.PeerIP;
    s := AContext.Connection.IOHandler.ReadLn;
    if SameText(S, 'file') then
    begin
      LogInfo(PIP + ': Query to send file.');
      AContext.Connection.IOHandler.WriteLn('-filename');
      S := AContext.Connection.IOHandler.ReadLn;
      if Pos('filename', S) = 1 then
      begin
        SaveFileName := Copy(S, Pos(':', S) + 1, Length(S));
        LogInfo(PIP + ': Post file name: "' + SaveFileName + '"');
        FileStream := TFileStream.Create(ExtractFilePath(ParamStr(0)) + SaveFileName,
          fmCreate);
        try
          AContext.Connection.IOHandler.WriteLn('-size');
          s := AContext.Connection.IOHandler.ReadLn;
          Size := StrToInt64Def(s, -1);
          if Size > -1 then
          begin
            AContext.Connection.IOHandler.WriteLn('-ready');
            LogInfo(PIP + ': Sending file(size:' + IntToStr(Size) + ')...');
            AContext.Connection.IOHandler.LargeStream := True;
            AContext.Connection.IOHandler.ReadStream(FileStream, Size);
            LogInfo(PIP + ': File sent. Size of file is ' + IntToStr(FileStream.Size));
          end;
        finally
          FileStream.Free;
        end;
        AContext.Connection.IOHandler.WriteLn('-ok');
      end
      else
        raise Exception.Create('File name requited but no name has been sent.');
    end;
  end;
end;

procedure TForm1.LockUI;
begin
  EnterCriticalSection(FSection);
end;

procedure TForm1.UnlockUI;
begin
  LeaveCriticalSection(FSection);
end;

constructor TForm1.Create(AOwner: TComponent);
begin
  InitializeCriticalSection(FSection);
  inherited;
end;

destructor TForm1.Destroy;
begin
  inherited;
  DeleteCriticalSection(FSection);
end;

procedure TForm1.IdTCPServerException(AContext: TIdContext;
  AException: Exception);
var
  PIP: string;
begin
  PIP := AContext.Binding.PeerIP;
  LogInfo(PIP + ' raise exception:' + AException.Message, clMaroon);
end;

procedure TForm1.IdTCPServerConnect(AContext: TIdContext);
var
  PIP: string;
begin
  PIP := AContext.Binding.PeerIP;
  LogInfo(PIP + ': Connected');
end;

procedure TForm1.IdTCPServerDisconnect(AContext: TIdContext);
var
  PIP: string;
begin
  PIP := AContext.Binding.PeerIP;
  LogInfo(PIP + ': Disconnected');
end;

end.