scanclasses.pas

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

{
********************************************************************************
*                                                                              * 
*             (c) China Systems 1999 - 2003                                    *   
*                                                                              * 
*               Prexim Imaging development team.                               * 
*                                                                              * 
********************************************************************************
*
* Unit Name: ScanClasses.pas
* Author:    Licwing
* Purpose:   
********************************************************************************
}
unit ScanClasses;
//==============================================================================
{* |<PRE>
 Unit name: ScanClasses.pas
 Author:    Licwing
 Purpose: 
 Develop Platform: Win2K pro & sp3 + delphi6 & patch2 
 Test Platform: 
 History:
   08-26-2003  V1.0  by Licwing
     -> first version  
|</PRE>}         
//==============================================================================

interface
uses
  Classes, SysUtils, Contnrs,
  // PrExim Modules
  PrEximClasses, PrEximTrans;

type
  TStreamedObject = class(TBaseStorageObject)
  public
    procedure SaveToStream(Stream : TStream); override;
    procedure LoadFromStream(Stream : TStream); override;
  end;

  TUser = class(TStreamedObject)
  private
    fID: string;
    fDescription: string;
    fPassword: string;
    fCreator: string;
    fName: string;
    fRole: TUserRight;
    fCreateDate: TDatetime;
    fBuildIn: boolean;
  protected
    procedure ReadData(Reader : TReader); override;
    procedure WriteData(Writer : TWriter); override;
  public
    constructor Create; override;

    function EqualTo(AUser: TUser): boolean;
    procedure Assign(Source: TPersistent); override;

    property ID: string read fID write fID;
    property Name: string read fName write fName;
    property BuildIn: boolean read fBuildIn write fBuildIn;
    property Description: string read fDescription write fDescription;
    property Password: string read fPassword write fPassword;
    property Role: TUserRight read fRole write fRole;
    property Creator: string read fCreator write fCreator;
    property CreateDate: TDatetime read fCreateDate write fCreateDate;
  end;

  TUserList = class(TStreamObjectList)
  private
    function GetItem(Index: Integer): TUser;
    procedure SetItem(Index: Integer; const AUser: TUser);
  protected
    procedure ReadData(Reader : TReader); override;
    procedure WriteData(Writer : TWriter); override;
  public
    function Add(AUser: TUser): Integer;
    function Extract(Item: TUser): TUser;
    function Remove(AUser: TUser): Integer;
    function New: TUser;
    function IndexOf(AUser: TUser): Integer;
    procedure Insert(Index: Integer; AUser: TUser);
    function First: TUser;
    function Last: TUser;
    property Items[Index: Integer]: TUser read GetItem write SetItem; default;
  end;

  TType = class(TStreamedObject)
  private
    fCaption: string;
    fID: string;
    fName: string;
  protected
    procedure ReadData(Reader : TReader); override;
    procedure WriteData(Writer : TWriter); override;
  public
    constructor Create; override;

    function EqualTo(AType: TType): boolean;
    procedure Assign(Source: TPersistent); override;

    property ID: string read fID write fID;
    property Caption: string read fCaption write fCaption;
    property Name: string read fName write fName;
  end;

  TTypeList = class(TStreamObjectList)
  private
    function GetItem(Index: Integer): TType;
    procedure SetItem(Index: Integer; const AType: TType);
  protected
    procedure ReadData(Reader : TReader); override;
    procedure WriteData(Writer : TWriter); override;
  public
    function Add(AType: TType): Integer;
    function Extract(Item: TType): TType;
    function Remove(AType: TType): Integer;
    function New: TType;
    function IndexOf(AType: TType): Integer;
    procedure Insert(Index: Integer; AType: TType);
    function First: TType;
    function Last: TType;
    property Items[Index: Integer]: TType read GetItem write SetItem; default;

    function EqualTo(ATypeList: TTypeList): boolean;
  end;

  TListValuePair = class(TStreamedObject)
  private
    fListDisplay: string;
    fListValue: string;
    fID: string;
  protected
    procedure ReadData(Reader : TReader); override;
    procedure WriteData(Writer : TWriter); override;
  public
    constructor Create; override;

    function EqualTo(AListValuePair: TListValuePair): boolean;
    procedure Assign(Source: TPersistent); override;

    property ID: string read fID write fID;
    property ListValue: string read fListValue write fListValue;
    property ListDisplay: string read fListDisplay write fListDisplay;
  end;

  TListValuePairList = class(TStreamObjectList)
  private
    function GetItem(Index: Integer): TListValuePair;
    procedure SetItem(Index: Integer; const AListValuePair: TListValuePair);
  protected
    procedure ReadData(Reader : TReader); override;
    procedure WriteData(Writer : TWriter); override;
  public
    function Add(AListValuePair: TListValuePair): Integer;
    function Extract(Item: TListValuePair): TListValuePair;
    function Remove(AListValuePair: TListValuePair): Integer;
    function New: TListValuePair;
    function IndexOf(AListValuePair: TListValuePair): Integer;
    procedure Insert(Index: Integer; AListValuePair: TListValuePair);
    function First: TListValuePair;
    function Last: TListValuePair;
    property Items[Index: Integer]: TListValuePair read GetItem write SetItem; default;

    function EqualTo(AListValuePairList: TListValuePairList): boolean;
  end;

  TParameter = class(TStreamedObject)
  private
    fIsList: boolean;
    fID: string;
    fDefaultValue: string;
    fType: string;
    fName: string;
    fListValueParis: TListValuePairList;
    FIsShow: boolean;
    FStatus: TKeyStatus;
    procedure SetIsList(const Value: boolean);
    procedure SetStatus(const Value: TKeyStatus);
  protected
    procedure ReadData(Reader : TReader); override;
    procedure WriteData(Writer : TWriter); override;
  public
    constructor Create; override;
    destructor Destroy; override;

    function EqualTo(AParameter: TParameter): boolean;
    procedure Assign(Source: TPersistent); override;
    function IsSystem: boolean;

    property ID: string read fID write fID;
    property Name: string read fName write fName;
    property ParamType: string read fType write fType;
    property DefaultValue: string read fDefaultValue write fDefaultValue;
    property IsList: boolean read fIsList write SetIsList;
    property ListValueParis: TListValuePairList read fListValueParis;// write fListValueParis;
    property IsShow: boolean read FIsShow write FIsShow;
    property Status: TKeyStatus read FStatus write SetStatus;
  end;

  TParameterList = class(TStreamObjectList)
  private
    function GetItem(Index: Integer): TParameter;
    procedure SetItem(Index: Integer; const AParam: TParameter);
  protected
    procedure ReadData(Reader : TReader); override;
    procedure WriteData(Writer : TWriter); override;
  public
    function Add(AParam: TParameter): Integer;
    function Extract(Item: TParameter): TParameter;
    function Remove(AParam: TParameter): Integer;
    function New: TParameter;
    function IndexOf(AParam: TParameter): Integer;
    procedure Insert(Index: Integer; AParam: TParameter);
    function First: TParameter;
    function Last: TParameter;
    property Items[Index: Integer]: TParameter read GetItem write SetItem; default;

    function EqualTo(AParameterList: TParameterList): boolean;
  end;


 { TParameterTool = class(TObject)
  public
    //Parameters
    function GetFolderParameters(AParamList: TParameterList): boolean;
    function GetFolderParameter(AID: String; AParameter: TParameter): boolean;
    function AddFolderParameter(AParam: TParameter): boolean;
    function UpdateFolderParameter(AParam: TParameter): boolean;
    function DeleteFolderParameter(AID: String): boolean;

    function GetTransactionParameters(AParamList: TParameterList): boolean;
    function GetTransactionParameter(AID: String; AParameter: TParameter): boolean;
    function AddTransactionParameter(AParam: TParameter; AParameter: TParameter): boolean;
    function UpdateTransactionParameter(AParam: TParameter): boolean;
    function DeleteTransactionParameter(AID: String): boolean;

    function GetDocumentParameters(AParamList: TParameterList): boolean;
    function GetDocumentParameter(AID: String; AParameter: TParameter): boolean;
    function AddDocumentParameter(AParam: TParameter): boolean;
    function UpdateDocumentParameter(AParam: TParameter): boolean;
    function DeleteDocumentParameter(AID: String): boolean;
  end;                                                 }

implementation

procedure ReadUserRight(Reader: TReader; var UserRight: TUserRight);
var
  Count: integer;
  AUserRightKind: TUserRightKind;
begin
  Count := 0;
  Reader.Read(Count, Sizeof(integer));

  while Count>0 do
  begin
    Reader.Read(AUserRightKind, Sizeof(TUserRightKind));
    UserRight := UserRight + [AUserRightKind];
    Dec(Count);
  end;
end;

procedure WriteUserRight(Writer: TWriter; UserRight: TUserRight);
var
  Count: integer;
  AUserRightKind: TUserRightKind;
begin
  Count := 0;
  for AUserRightKind:=Low(TUserRightKind) to High(TUserRightKind) do
    if AUserRightKind in UserRight then Inc(Count);

  Writer.Write(Count, Sizeof(integer));

  if Count<1 then exit;

  for AUserRightKind:=Low(TUserRightKind) to High(TUserRightKind) do
    if AUserRightKind in UserRight then
      Writer.Write(AUserRightKind, Sizeof(TUserRightKind));
end;

{ TUserList }

function TUserList.Add(AUser: TUser): Integer;
begin
  Result := inherited Add(AUser);
end;

function TUserList.Extract(Item: TUser): TUser;
begin
  Result := TUser(inherited Extract(Item));
end;

function TUserList.First: TUser;
begin
  Result := TUser(inherited First);
end;

function TUserList.GetItem(Index: Integer): TUser;
begin
  Result := TUser(inherited Items[Index]);
end;

function TUserList.IndexOf(AUser: TUser): Integer;
begin
  Result := inherited IndexOf(AUser);
end;

procedure TUserList.Insert(Index: Integer; AUser: TUser);
begin
  inherited Insert(Index, AUser);
end;

function TUserList.Last: TUser;
begin
  Result := TUser(inherited Last);
end;

function TUserList.New: TUser;
begin
  Result := TUser.Create;
  Add(Result);
end;

procedure TUserList.ReadData(Reader: TReader);
var
  AUser: TUser;
  cName: string;
  UsersCount: integer;
begin
  // read TPageList signature
  Reader.ReadSignature;
  inherited;

  // clear all old items
  Clear;

  with Reader do
  begin
    // read beginning of file and beginning of object list markers
    UsersCount := ReadInteger;
    //loop through file list of objects
    while UsersCount > 0 do
    begin
      //Load ClassName and use it to get ClassType
      cName := ReadString;

      // If a ClassType was found create an instance and
      // add object to this list
      if cName = TUser.ClassName  then
      begin
        AUser := New;
        AUser.ReadData(Reader);
      end;
      Dec(UsersCount);

      //ProcessWindowsMessageQueue;
    end;
  end;
end;

function TUserList.Remove(AUser: TUser): Integer;
begin
  Result := inherited Remove(AUser);
end;

procedure TUserList.SetItem(Index: Integer; const AUser: TUser);
begin
   inherited Items[Index] := AUser;
end;

procedure TUserList.WriteData(Writer: TWriter);
var
  Idx: integer;
begin
  // write TPageList signature;
  Writer.WriteSignature;
  inherited;

  with Writer do
  begin
    // mark beginning of file and beginning of object list
    WriteInteger(Count);

    for Idx := 0 to Count - 1 do
    begin
      if TObject(Items[Idx]) is TUser then
      begin
        WriteString(TUser(Items[Idx]).ClassName);
        TUser(Items[Idx]).WriteData(Writer);
      end;

      //ProcessWindowsMessageQueue;
    end;
  end;
end;

{ TUser }

procedure TUser.Assign(Source: TPersistent);
var
  AUser: TUser;
begin
  AUser := TUser(Source);
  fID                 := AUser.ID;
  fDescription        := AUser.Description;
  fPassword           := AUser.Password;
  fCreator            := AUser.Creator;
  fName               := AUser.Name;
  fRole               := AUser.Role;
  fCreateDate         := AUser.CreateDate;
  fBuildIn            := AUser.BuildIn;
end;

constructor TUser.Create;
begin
  inherited;
  fID                 := '';
  fDescription        := '';
  fPassword           := '';
  fCreator            := '';
  fName               := '';
  fRole               := [];
  fCreateDate         := -1;
  fBuildIn            := false;
end;

function TUser.EqualTo(AUser: TUser): boolean;
begin
//  with AUser do
//  begin
  if (fID=AUser.ID) and (fName=AUser.Name) then
    Result := (fPassword=AUser.Password) and (fCreator=AUser.Creator) and (fRole=AUser.Role)
               and (fCreateDate=AUser.CreateDate) and (fBuildIn=AUser.BuildIn)
               and (fDescription=AUser.fDescription)
  else Result := false;
//  end;
end;

procedure TUser.ReadData(Reader: TReader);
begin
  inherited;
  with Reader do
  begin
    fID                 := ReadString;
    fDescription        := ReadString;
    fPassword           := ReadString;
    fCreator            := ReadString;
    fName               := ReadString;
    //fRole               := ReadString;
    fCreateDate         := ReadDate;
    fBuildIn            := ReadBoolean;
  end;
  ReadUserRight(Reader, fRole);
end;

procedure TUser.WriteData(Writer: TWriter);
begin
  inherited;
  with Writer do
  begin
    WriteString(fID);
    WriteString(fDescription);
    WriteString(fPassword);
    WriteString(fCreator);
    WriteString(fName);
    //WriteString(fRole);
    WriteDate(fCreateDate);
    WriteBoolean(fBuildIn);
  end;
  WriteUserRight(Writer, fRole);
end;

{ TTypes }

procedure TType.Assign(Source: TPersistent);
begin
  fID                 := TType(Source).ID;
  fName               := TType(Source).Name;
  fCaption            := TType(Source).Caption;
end;

constructor TType.Create;
begin
  inherited;
  fID           := '';
  fCaption      := '';
end;

function TType.EqualTo(AType: TType): boolean;
begin
  if (fID=AType.ID) and (fName=AType.Name) then
    Result := (fCaption=AType.Caption)
  else Result := false;
end;

procedure TType.ReadData(Reader: TReader);
begin
  inherited;
  with Reader do
  begin
    fID         := ReadString;
    fCaption    := ReadString;
    fName       := ReadString;
  end;
end;

procedure TType.WriteData(Writer: TWriter);
begin
  inherited;
  with Writer do
  begin
    WriteString(fID);
    WriteString(fCaption);
    WriteString(fName);
  end;
end;

{ TStreamedObject }

procedure TStreamedObject.LoadFromStream(Stream: TStream);
var
  Reader: TReader;
begin
  Reader := TReader.Create(Stream, $FF);
  try
    ReadData(Reader);
  finally
    FreeAndNil(Reader);
  end;
end;


procedure TStreamedObject.SaveToStream(Stream: TStream);
var
  Writer: TWriter;
begin
  Writer := TWriter.Create(Stream, $FF);
  try
    WriteData(Writer);
  finally
    FreeAndNil(Writer);
  end;
end;

{ TTypeList }

function TTypeList.Add(AType: TType): Integer;
begin
  Result := inherited Add(AType);
end;

function TTypeList.EqualTo(ATypeList: TTypeList): boolean;
var
  Idx: integer;