userver.pas

一个很好的学习例子,有需要的请下载研究,

unit uServer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, PrEximTrans, PrEximClasses, TransInterface,
  IdBaseComponent, IdComponent, IdTCPServer;

type
  TfrmMain = class(TForm)
    Log: TMemo;
    Panel1: TPanel;
    btnStart: TButton;
    btnStop: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnStartClick(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
  private
    fTcpServer: TImageTransServer;
    fServer: TScanServer;

    procedure SetServer(Active: boolean);
    procedure LogMsg(const AMsg: string='');

    procedure DoLogin(const Username, Password: string;
       var Logged: boolean; UserRight: TUserRight; var ErrMsg: string);
    procedure DoLogout(const Username: string);
    procedure DoGetUserProfile(const Username: string; UserProfile: TStream; var ErrMsg: string);
    procedure DoSendFolder(AFolder: TFolder; const User: string; var Flag: boolean; var ErrMsg: string);
    procedure DoGetAllFaxes(APageList: TPageList; var Flag: boolean; var ErrMsg: string);
    procedure DoCreateFolder(AFolder: TFolder; const User: string; var Flag: boolean; var ErrMsg: string);
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  fTcpServer := TImageTransServer.Create(Owner);
  fServer := TScanServer.Create(Owner);

  fServer.Transport := fTcpServer;
  
  fServer.OnLogin := DoLogin;
  fServer.OnLogout := DoLogout;
  fServer.OnGetUserProfile := DoGetUserProfile;
  fServer.OnSendFolder := DoSendFolder;
  fServer.OnGetAllFaxes := DoGetAllFaxes;
  fServer.OnCreateFolder := DoCreateFolder;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if fServer.Transport.Active then SetServer(false);

  FreeAndNil(fTcpServer);
  FreeAndNil(fServer);
end;

procedure TfrmMain.SetServer(Active: boolean);
begin
  fServer.Transport.Active := Active;
  btnStart.Enabled := not Active;
  btnStop.Enabled := Active;
end;

procedure TfrmMain.btnStartClick(Sender: TObject);
begin
  SetServer(true);
end;

procedure TfrmMain.btnStopClick(Sender: TObject);
begin
  SetServer(false);
end;

procedure TfrmMain.LogMsg(const AMsg: string);
begin
  Log.Lines.Add(AMsg)
end;

procedure TfrmMain.DoLogin(const Username, Password: string;
  var Logged: boolean; UserRight: TUserRight; var ErrMsg: string);
begin
  LogMsg(Username + ' try to log, password is '+Password);
  if Username = '12345' then
  begin
    Logged := false;
    ErrMsg := 'failed';
  end
  else begin
    Logged := true;
    ErrMsg := 'No Error';
  end;
end;

procedure TfrmMain.DoLogout(const Username: string);
begin
  LogMsg(Username + ' logout');
end;

procedure TfrmMain.DoGetUserProfile(const Username: string;
  UserProfile: TStream; var ErrMsg: string);
var
  AFileStream: TMemoryStream;
begin
  LogMsg(Username + ' try to get own profile');
  AFileStream := TMemoryStream.Create;
  try
    AFileStream.LoadFromFile('c:\user.txt');

    UserProfile.CopyFrom(AFileStream, AFileStream.Size);
    UserProfile.Position := 0;
    Log.Lines.LoadFromStream(UserProfile);
    LogMsg('UserProfile size='+IntToStr(UserProfile.Size));
    
  finally
    AFileStream.Free;
  end;  
end;

procedure TfrmMain.DoSendFolder(AFolder: TFolder; const User: string;
  var Flag: boolean; var ErrMsg: string);
begin
  LogMsg(' SendFolder by '+ user);
  LogMsg('Folder Name='+AFolder.Keys.Items[0].Name);
end;

procedure TfrmMain.DoGetAllFaxes(APageList: TPageList; var Flag: boolean; var ErrMsg: string);
var
  APage: TPage;
begin
  LogMsg('GetAllFaxes, Add a new fax, file is c:\linux.txt');
  APage := APageList.New;
  APage.Filename := 'C:\linux.txt';
end;

procedure TfrmMain.DoCreateFolder(AFolder: TFolder;const User: string; var Flag: boolean; var ErrMsg: string);
begin

  LogMsg('CreateFolder by '+User);
  LogMsg('Folder Name='+AFolder.Keys.Items[0].Name);
  if User='username' then
  begin
    Flag := false;
    ErrMsg := User+' no right to create a folder';
  end;
end;

end.