archiverroot.pas

本系统在一些大中型企业(跨多达24个区域)一直都在很好的服务过

    FOnClearFileList : TNotifyEvent;
    FOnAddToLog : TOnAddToLogEvent;

    function  CreateMessages : TMessages; virtual;
    function  GetSignature : Integer; virtual;
    function  GetHeaderSize : Integer; virtual;
    procedure WriteHeader; virtual;
    procedure ReadHeader;
    function  ReadHeaderOfFile( const fileName : String; var AHeader : TArchiveHeader ) : Boolean;
    function  ReadHeaderOfStream( S : TStream; var AHeader : TArchiveHeader ) : Boolean; virtual;
    procedure CheckOpen;
    function  GetDirectorySize( const dir : String ) : Integer;
    procedure Start; virtual;
    procedure Finish; virtual;
    procedure UpdateProgress;
    procedure InitCompression; virtual;
    procedure InitCrypting; virtual;
    procedure EnterCryptKey; virtual;
    procedure RequestCryptKey; virtual;
    function  GetMinKeySize : Integer; virtual;
    procedure SetBlockSize( val : Integer );
    procedure AllocBlocks;
    procedure DeallocBlocks;
    function  CanContinue( E : Exception ) : Boolean;
    function  NeededBlockSize : Integer; virtual;
    function  GetLanguage : TLanguage;
    procedure SetLanguage( val : TLanguage );
    procedure SetMessages( val : TMessages );
    procedure SetFileName( const val : String );
    procedure ExplodeFileName;
    function  GetFileEntrySize( const fileEntry : TFileEntry ) : Integer;
    procedure WriteFileEntry( var fileEntry : TFileEntry );
    procedure ReadFileEntry( var fileEntry : TFileEntry );
    function  IsRemovableDisk( const drive : String ) : Boolean;
    function  GetSegmentName( segment : Word ) : String;
    procedure CreateStream;
    procedure OpenStream;
    procedure CloseStream;
    procedure CheckReadOnly;
    procedure CheckKey;
    procedure BeforeOpen; virtual;
    procedure AfterOpen; virtual;
    procedure BeforeClose; virtual;
    procedure AfterClose; virtual;
    procedure AfterUpdate; virtual;
    function  GetTempFileName : String;
    procedure GetProgressInformations; virtual;
    procedure CreateArchive; virtual;
    function  GetOpenMode : Integer; virtual;
    function  RequestSpace( val : Integer ) :  Boolean; virtual;
    function  CheckEOF : Boolean; virtual;
    function  SelectDirectory(var Directory: string; Options: TMySelectDirOpts; HelpCtx: Longint):Boolean; virtual;
    procedure ForceDirectories(Dir: string);
    function  SelectFile( const Title : String; var FileName : String ) : Boolean; virtual;
    function  MessageDlg( const Msg: string; DlgType: TMyMsgDlgType;
                          Buttons: TMyMsgDlgButtons; HelpCtx: Longint): Integer; virtual;
    function  InputQuery(const ACaption, APrompt: string; var AValue: string): Boolean; virtual;
    function  QueryPassword(const ACaption, APrompt: string; var AValue: string): Boolean; virtual;
    function  GetStartOffset : Integer;
    procedure CheckSFX( const aFileName : String ); virtual;
    procedure Loaded; override;
    procedure OpenSolidData; virtual;
    procedure CloseSolidData; virtual;
    procedure StartTimer;
    procedure StopTimer;
    procedure ShowTiming;
    function  GetElapsedTime : TDateTime;
    procedure DisplayMessage( const msg : String );
    procedure AddToLog( const msg : String );
    procedure CopyStream( Src, Dest : TStream; trapExceptions : Boolean );
    function  CopyFile( const srcName, destName : String; failIfExists, trapExceptions : Boolean ) : Boolean;
    procedure ClearFiles;
    procedure AddFileToList( const entry : TFileEntry );
    function  GetFiles( idx : Integer ) : TFileObject;
    function  GetFileCount : Integer;
    procedure AdjustArchiveSize;

  public
    // Creators & Destructor
    constructor Create( AOwner : TComponent ); override;
    destructor  Destroy; override;

    // Public methods

    // Open/close Archive
    procedure Open;
    procedure CreateTempFile;
    procedure Close;
    function  Reset : Boolean;
    function  Delete : Boolean;
    function  Rename( const NewName : String ) : Boolean;

    // Misc methods
    function  IsStreamOpen : Boolean;
    function  DeleteDirectory( const dir : String ) : Boolean;
    function  DeleteDriveContent( const drive : String ) : Boolean;
    function  IsSegmented : Boolean;
    function  IsEmpty : Boolean;
    function  IsBusy : Boolean;
    function  IndexOfFile( const FileName : String ) : Integer;
    function  CanAbort : Boolean;
    procedure RequestAbort;

    // Public properties
    property ArchiveDrive : String read FArchiveDrive;
    property ArchiveName : String read FArchiveName;
    property ArchiveDir : String read FArchiveDir;
    property ArchiveExt : String read FArchiveExt;
    property CheckAvailableSpace : Boolean read FCheckAvailableSpace write FCheckAvailableSpace;
    property CurrentFileEntry : TFileEntry read FCurrentFileEntry;
    property Operation : TOperation read FOperation;
    property Stream : TStream read FStream;
    property Header : TArchiveHeader read FHeader;
    property IsOpen : Boolean read FIsOpen write FIsOpen;
    property ReadOnly : Boolean read FReadOnly;
    property StartOffset : Integer read FStartOffset write FStartOffset;
    property SFXCodeSize : Integer read FSFXCodeSize write FSFXCodeSize;
    property IsSolidArchive : Boolean read FIsSolidArchive;
    property ElapsedTime : TDateTime read GetElapsedTime;
    property StartTime : TDateTime read FStartTime;
    property EndTime : TDateTime read FEndTime;
    property BytesPerMSec : Extended read FBytesPerMSec;
    property BytesToProcess : TArchiveSize read FBytesToProcess;
    property BytesProcessed : TArchiveSize read FBytesProcessed;
    property Percent : Integer read FPercent;
    property FileCount : Integer read GetFileCount;
    property Files[ idx : Integer ] : TFileObject read GetFiles;
    property ArchiveChanged : Boolean read FArchiveChanged;
    property MinKeySize : Integer read GetMinKeySize;

  published
    // Properties
    property BlockSize : Integer read FBlockSize write SetBlockSize;
    property ErrorAction : TErrorAction read FErrorAction write FErrorAction;
    property FileName : String read FFileName write SetFileName;
    property Filter : String read FFilter write FFilter;
    property Language : TLanguage read GetLanguage write SetLanguage;
    property Messages : TMessages read FMessages write SetMessages;
    property Options : TOptions read FOptions write FOptions;
     // Events
    property OnAcceptArchive : TOnAcceptArchiveEvent read FOnAcceptArchive write FOnAcceptArchive;
    property OnWriteUserData : TOnWriteUserDataEvent read FOnWriteUserData write FOnWriteUserData;
    property OnError : TOnErrorEvent read FOnError write FOnError;
    property OnFileProgress : TOnFileProgressEvent read FOnFileProgress write FOnFileProgress;
    property OnFinishOperation : TNotifyEvent read FOnFinishOperation write FOnFinishOperation;
    property OnStartOperation : TNotifyEvent read FOnStartOperation write FOnStartOperation;
    property OnEnterCryptKey : TOnEnterCryptKeyEvent read FOnEnterCryptKey write FOnEnterCryptKey;
    property OnRequestCryptKey : TOnRequestCryptKeyEvent read FOnRequestCryptKey write FOnRequestCryptKey;
    property OnBeforeOpen : TNotifyEvent read FOnBeforeOpen write FOnBeforeOpen;
    property OnAfterOpen : TNotifyEvent read FOnAfterOpen write FOnAfterOpen;
    property OnBeforeClose : TNotifyEvent read FOnBeforeClose write FOnBeforeClose;
    property OnAfterClose : TNotifyEvent read FOnAfterClose write FOnAfterClose;
    property OnGetSignature : TOnGetSignatureEvent read FOnGetSignature write FOnGetSignature;
    property OnAfterHeaderUpdate : TNotifyEvent read FOnAfterHeaderUpdate write FOnAfterHeaderUpdate;
    property OnShowComment : TOnShowCommentEvent read FOnShowComment write FOnShowComment;
    property OnShowTiming : TOnShowTimingEvent read FOnShowTiming write FOnShowTiming;
    property OnDisplayMessage : TOnDisplayMessageEvent read FOnDisplayMessage write FOnDisplayMessage;
    property OnClearFileList : TNotifyEvent read FOnClearFileList write FOnClearFileList;
    property OnAddToLog : TOnAddToLogEvent read FOnAddToLog write FOnAddToLog;
  end;

  function  GetUserLanguage : TLanguage;

implementation


function  GetUserLanguage : TLanguage;
var
  xLanguage : Integer;
begin
  xLanguage := (LoWord(GetUserDefaultLangID) and $3ff);
  case xLanguage of
    LANG_GERMAN    : Result := lgGerman;
    LANG_ENGLISH   : Result := lgEnglish;
    LANG_SPANISH   : Result := lgSpanish;
    LANG_RUSSIAN   : Result := lgRussian;
    LANG_ITALIAN   : Result := lgItalian;
    LANG_FRENCH    : Result := lgFrench;
    LANG_PORTUGUESE: Result := lgPortuguese;
    LANG_CHINESE:    Result := lgChinese;
  else
                     Result := lgEnglish;
  end;
end;

////////////////////////////////////////////////////////////

procedure TMessages.AssignTo(Dest: TPersistent);
begin
  if Dest is TMessages then
    with TMessages( Dest ) do begin
      FBadSignature        := Self.FBadSignature;
      FFileNameNeeded      := Self.FFileNameNeeded;
      FSystemMessage       := Self.FSystemMessage;
      FAcceptArchiveFailed := Self.FAcceptArchiveFailed;
      FEnterCryptKey       := Self.FEnterCryptKey;
      FEnterDecryptKey     := Self.FEnterDecryptKey;
      FArchiveIsReadOnly   := Self.FArchiveIsReadOnly;
      FKeyTooShort         := Self.FKeyTooShort;
      FConfirmCryptKey     := Self.FConfirmCryptKey;
      FKeyNotConfirmed     := Self.FKeyNotConfirmed;
      FCanNotCreateArchive := Self.FCanNotCreateArchive;
      FCannotCreateDir     := Self.FCannotCreateDir;
      FSelectADirectory    := Self.FSelectADirectory;
      FOk                  := Self.FOK;
      FCancel              := Self.FCancel;
      FInformation         := Self.FInformation;
      FWarning             := Self.FWarning;
      FConfirmation        := Self.FConfirmation;
      FError               := Self.FError;
      FCanNotBuildTempFileName := Self.FCanNotBuildTempFileName;
      FYes                     := Self.FYes;
      FYesToAll                := Self.FYesToAll;
      FNo                      := Self.FNo;
      FFile                    := Self.FFile;
      FCanContinue             := Self.FCanContinue;
      FUnknownVersion          := Self.FUnknownVersion;
    end;
  SetGlobalStrings;
  inherited AssignTo( Dest );
end;

constructor TMessages.Create;
begin
  inherited;
  Language := lgAutomatic;
end;

procedure TMessages.PropSetLanguage( language : TLanguage );
begin
  SetLanguage( language );
  SetGlobalStrings;
end;

procedure TMessages.SetLanguage( language : TLanguage );
var
  lang : TLanguage;
begin
  FLanguage := language;
  if FLanguage = lgAutomatic then
    lang := GetUserLanguage
  else
    lang := FLanguage;
  case lang of
    lgEnglish:
      begin
        FBadSignature := 'Bad signature: file "%s" is not a valid archive';
        FFileNameNeeded := '"Archiver" needs property "FileName"';
        FSystemMessage := 'System Message';
        FAcceptArchiveFailed := 'This archive can not be used';
        FEnterCryptKey := 'Enter the encrypt key:';
        FEnterDecryptKey := 'Enter the decrypt key:';
        FArchiveIsReadOnly := 'Archive is ReadOnly';
        FKeyTooShort := 'The key is too short. It must contain %d chars at least.';
        FConfirmCryptKey := 'Confirm the encrypt key:';
        FKeyNotConfirmed := 'The key could not be confirmed. Enter it again.';
        FCanNotCreateArchive := 'This component can not create an archive';
        FCannotCreateDir := 'Can not create directory';
        FSelectADirectory := 'Select a directory:';
        FOk := 'OK';
        FCancel := 'Cancel';
        FInformation := 'Information';
        FWarning := 'Warning';
        FConfirmation := 'Confirmation';
        FError := 'Error';
        FCanNotBuildTempFileName := 'Can not build a temporary FileName';
        FYes := '&Yes';
        FYesToAll := 'Yes to &All';
        FNo := '&No';
        FFile := 'File';
        FCanContinue := 'Do you want to continue ?';
        FUnknownVersion := 'Unknown version';
      end;
    lgFrench:
      begin
        FBadSignature := 'Mauvaise signature: le fichier "%s" n''est pas une archive valide';
        FFileNameNeeded := '"Archiver" n閏essite la propri閠