archivermisc.pas

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

unit ArchiverMisc;
{
  TArchiver by Morgan Martinet (C) 1998 - [e-mail] or [e-mail]

  this unit contains several functions used by the other units
  implementing TArchiver.
}

interface
  uses Windows, Messages, Classes, SysUtils;

  // Dialog / Query functions
  const
    mrNone     = 0;
    mrOk       = idOk;
    mrCancel   = idCancel;
    mrAbort    = idAbort;
    mrRetry    = idRetry;
    mrIgnore   = idIgnore;
    mrYes      = idYes;
    mrNo       = idNo;
    mrAll      = mrNo + 1;
    //mrNoToAll  = mrAll + 1;
    //mrYesToAll = mrNoToAll + 1;
  type
    TMyMsgDlgType = (mtWarning, mtError, mtInformation, mtConfirmation, mtCustom);
    TMyMsgDlgBtn = (mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, mbIgnore,
      mbAll, {mbNoToAll, mbYesToAll,} mbHelp);
    TMyMsgDlgButtons = set of TMyMsgDlgBtn;
  var
    MyModalResults: array[TMyMsgDlgBtn] of Integer = (
      mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, {mrNoToAll,
      mrYesToAll,} 0);
  function MessageDlg( const Msg: string; DlgType: TMyMsgDlgType;
                       Buttons: TMyMsgDlgButtons; HelpCtx: Longint): Integer;
  function InputQuery(const ACaption, APrompt: string; var AValue: string): Boolean;
  function QueryPassword(const ACaption, APrompt: string; var AValue: string): Boolean;
  function QueryFileOverwrite( const oldFileName, newFileName : String;
                               oldFileSize, newFileSize : Integer;
                               oldFileDate, newFileDate : TDateTime ) : Integer;
  function QueryContinue( const ErrorMsg, FileName : String;
                          FileSize : Integer;
                          FileDate : TDateTime ) : Integer;

  // Stream functions
  function  ReadInteger( S : TStream ) : Integer;
  procedure WriteInteger( S : TStream; val : Integer );
  function  ReadWord( S : TStream ) : Word;
  procedure WriteWord( S : TStream; val : Word);
  function  ReadFloat( S : TStream ) : Extended;
  procedure WriteFloat( S : TStream; val : Extended );
  function  ReadBoolean( S : TStream ) : Boolean;
  procedure WriteBoolean( S : TStream; val : Boolean );
  function  ReadString( S : TStream ) : String;
  procedure WriteString( S : TStream; val : String );

  // Misc
  function  RemoveSlash( const sDir : String ) : String;
  function  AppendSlash( const sDir : String ) : String;
  function  AdjustPath( const path : String; maxSize : Integer ) : String;

  function  DiskInDrive(Drive: Char): Boolean;
  function  CRC32R( CRC :Longint; const Data; cbData :Longint ) :Longint;
  function  Min( a, b : Integer ) : Integer;
  function  Max( a, b : Integer ) : Integer;
  function  Abs( val : Integer ) : Integer;
  function  EncodeBlockSize( IsCompressed : Boolean; BlockSize : Integer ) : Integer;
  procedure DecodeBlockSize( size : Integer; var IsCompressed : Boolean;
                             var BlockSize : Integer );
  function  CalcRatio( size, compressedSize : Integer ) : Integer;
  function  DirectoryExists(const Name: string): Boolean;
  function  GetFileDate( const FileName : String ) : TDateTime;
  function  GetFileSize( const fileName : String ) : Integer;
  function  IsExeFile( const FileName : String ) : Boolean;
  function  GetTempDir : String;

  procedure GetVersionInfo( const FileName : String; Infos : TStrings );
  function MSecsAsTime( secs : Integer ) : TDateTime;
  function TimeAsMSecs( time : TDateTime ) : Integer;

  procedure GetDiskSizeAvail2( TheDrive : PChar;
                               var TotalBytes : double;
                               var TotalFree : double);
  procedure GetDiskSizeAvail( TheDrive : PChar; var TotalBytes : double; var TotalFree : double);

var
  strOk : String;
  strCancel : String;
  strInformation : String;
  strWarning : String;
  strConfirmation : String;
  strError : String;
  strYes : String;
  strYesToAll : String;
  strNo : String;
  strReplaceFile : String;
  strWithFile : String;
  strConfirmFileOverwrite : String;
  strFile : String;
  strCanContinue : String;

implementation
{$R ArchiverMisc.res}

/////////////////////////////////////////
// Dialog / Query functions
/////////////////////////////////////////


function MessageDlg(const Msg: string; DlgType: TMyMsgDlgType;
  Buttons: TMyMsgDlgButtons; HelpCtx: Longint): Integer;
var
  uType : Cardinal;
  title : String;
begin
  uType := MB_TASKMODAL;
  case DlgType of
  mtWarning:
    begin
      uType := uType or MB_ICONWARNING;
      title := strWarning;
    end;
  mtError:
    begin
      uType := uType or MB_ICONERROR;
      title := strError;
    end;
  mtInformation:
    begin
      uType := uType or MB_ICONINFORMATION;
      title := strInformation;
    end;
  mtConfirmation:
    begin
      uType := uType or MB_ICONQUESTION;
      title := strConfirmation;
    end;
  else
    begin
      uType := uType or MB_ICONINFORMATION;
      title := strInformation;
    end;
  end;
  if ([mbAbort, mbRetry, mbIgnore] - Buttons) = [] then
    uType := uType or MB_ABORTRETRYIGNORE
  else if ([mbYes, mbNo, mbCancel] - Buttons) = [] then
    uType := uType or MB_YESNOCANCEL
  else if ([mbYes, mbNo] - Buttons) = [] then
    uType := uType or MB_YESNO
  else if ([mbRetry, mbCancel] - Buttons) = [] then
    uType := uType or MB_RETRYCANCEL
  else if ([mbOk, mbCancel] - Buttons) = [] then
    uType := uType or MB_OKCANCEL
  else
    uType := uType or MB_OK;
  Result := MessageBox(
    GetActiveWindow,     // handle of owner window
    PChar(msg),    // address of text in message box
    PChar(title),  // address of title of message box
    uType          // style of message box
   );
end;

procedure CenterWindow( win : HWND );
var
  x, y, cx, cy : Integer;
  topRect, dlgRect : TRect;
begin
  GetWindowRect( GetDesktopWindow, topRect );
  GetWindowRect( win, dlgRect );
  cx := dlgRect.Right - dlgRect.Left;
  cy := dlgRect.Bottom - dlgRect.Top;
  x := ((topRect.Right - topRect.Left) - cx) div 2;
  y := ((topRect.Bottom - topRect.Top) - cy) div 2;
  SetWindowPos(
    win,       // handle of window
    0,         // placement-order handle
    x,         // horizontal position
    y,         // vertical position
    cx,        // width
    cy,        // height
    0          // window-positioning flags
  );

end;

type
  TQueryParams = record
    Caption : String;
    Prompt : String;
    Value : String;
  end;
  PQueryParam = ^TQueryParams;

function QueryProc(
    hwndDlg : HWND;	// handle of dialog box
    uMsg : Cardinal;	// message
    wp : WPARAM;	// first message parameter
    lp : lParam 	// second message parameter
   ) : BOOL; far; stdcall;
var
  pparams : PQueryParam;
begin
  Result := False;
  case uMsg of
  WM_INITDIALOG:
    begin
      pparams := PQueryParam(lp);
      SetDlgItemText( hwndDlg, 1, PChar(strOk) );
      SetDlgItemText( hwndDlg, 2, PChar(strCancel) );
      SetWindowLong( hwndDlg, DWL_USER, lp );
      CenterWindow( hwndDlg );
      with pparams^ do
        begin
          SetWindowText( hwndDlg, PChar(Caption) );
          SetDlgItemText( hwndDlg, 100, PChar(Prompt) );
          SetDlgItemText( hwndDlg, 101, PChar(Value) );
        end;
      SetFocus( GetDlgItem( hwndDlg, 101 ) );
    end;
  WM_CLOSE, WM_QUIT:
    begin
      EndDialog( hwndDlg, 0 );
      Result := True;
    end;
  WM_COMMAND:
    begin
      case wp of
      1:
        begin
          pparams := PQueryParam( GetWindowLong( hwndDlg, DWL_USER ) );
          with pparams^ do
            begin
              SetLength( Value, 512 );
              SetLength( Value, GetDlgItemText( hwndDlg, 101, PChar(Value), Length(Value) ) );
            end;
          EndDialog( hwndDlg, 1 );
          Result := True;
        end;
      2:
        begin
          EndDialog( hwndDlg, 0 );
          Result := True;
        end;
      end;
    end;
  end;
end;

function InputQuery(const ACaption, APrompt: string; var AValue: string): Boolean;
var
  id : Integer;
  params : TQueryParams;
begin
  with params do
    begin
      Caption := ACaption;
      Prompt  := APrompt;
      Value   := AValue;
    end;
  id := DialogBoxParam(
     hInstance,                // handle of application instance
     MakeIntResource(101),     // identifies dialog box template
     GetActiveWindow,          // handle of owner window
     @QueryProc,               // address of dialog box procedure
     Integer(@params)          // initialization value
    );
 Result := id > 0;
 if Result then
   AValue := params.Value;
end;

function QueryPassword(const ACaption, APrompt: string; var AValue: string): Boolean;
var
  id : Integer;
  params : TQueryParams;
begin
  with params do
    begin
      Caption := ACaption;
      Prompt  := APrompt;
      Value   := AValue;
    end;
  id := DialogBoxParam(
     hInstance,                // handle of application instance
     MakeIntResource(102),     // identifies dialog box template
     GetActiveWindow,          // handle of owner window
     @QueryProc,               // address of dialog box procedure
     Integer(@params)          // initialization value
    );
 Result := id > 0;
 if Result then
   AValue := params.Value;
end;


type
  TQueryOverwriteParams = record
    oldFileName, newFileName : String;
    oldFileSize, newFileSize : Integer;
    oldFileDate, newFileDate : TDateTime;
  end;
  PQueryOverwriteParam = ^TQueryOverwriteParams;

function QueryOverwriteProc(
    hwndDlg : HWND;	// handle of dialog box
    uMsg : Cardinal;	// message
    wp : WPARAM;	// first message parameter
    lp : lParam 	// second message parameter
   ) : BOOL; far; stdcall;
var
  pparams : PQueryOverwriteParam;
begin
  Result := False;
  case uMsg of
  WM_INITDIALOG:
    begin
      pparams := PQueryOverwriteParam(lp);
      SetDlgItemText( hwndDlg,   6, PChar(strYes) );
      SetDlgItemText( hwndDlg,   2, PChar(strCancel) );
      SetDlgItemText( hwndDlg, 102, PChar(strYesToAll) );
      SetDlgItemText( hwndDlg, 101, PChar(strNo) );
      SetDlgItemText( hwndDlg, 103, PChar(strReplaceFile) );
      SetDlgItemText( hwndDlg, 106, PChar(strWithFile) );
      SetWindowText( hwndDlg, PChar(strConfirmFileOverwrite) );
      SetWindowLong( hwndDlg, DWL_USER, lp );
      CenterWindow( hwndDlg );
      with pparams^ do
        begin
          SetDlgItemText( hwndDlg, 104, PChar(oldFileName) );
          SetDlgItemText( hwndDlg, 105, PChar(Format('%.0n bytes  %s',[oldFileSize*1.0, DateTimeToStr(oldFileDate)])) );
          SetDlgItemText( hwndDlg, 107, PChar(newFileName) );
          SetDlgItemText( hwndDlg, 108, PChar(Format('%.0n bytes  %s',[newFileSize*1.0, DateTimeToStr(newFileDate)])) );
        end;
    end;
  WM_CLOSE, WM_QUIT:
    begin
      EndDialog( hwndDlg, 0 );
      Result := True;
    end;
  WM_COMMAND:
    begin
      EndDialog( hwndDlg, wp );
      Result := True;
    end;
  end;
end;

function QueryFileOverwrite( const oldFileName, newFileName : String;
                             oldFileSize, newFileSize : Integer;
                             oldFileDate, newFileDate : TDateTime ) : Integer;
var
  params : TQueryOverwriteParams;
begin
  params.oldFileName := oldFileName;
  params.newFileName := newFileName;
  params.oldFileSize := oldFileSize;
  params.newFileSize := newFileSize;
  params.oldFileDate := oldFileDate;
  params.newFileDate := newFileDate;
  Result := DialogBoxParam(
     hInstance,                // handle of application instance
     MakeIntResource(103),     // identifies dialog box template
     GetActiveWindow,          // handle of owner window
     @QueryOverwriteProc,      // address of dialog box procedure
     Integer(@params)          // initialization value
    );
end;


type
  TQueryContinueParams = record
    ErrorMsg : String;
    FileName : String;
    FileSize : Integer;
    FileDate : TDateTime;
  end;
  PQueryContinueParam = ^TQueryContinueParams;

function QueryContinueProc(
    hwndDlg : HWND;	// handle of dialog box
    uMsg : Cardinal;	// message
    wp : WPARAM;	// first message parameter
    lp : lParam 	// second message parameter
   ) : BOOL; far; stdcall;
var
  pparams : PQueryContinueParam;
begin
  Result := False;
  case uMsg of
  WM_INITDIALOG:
    begin
      pparams := PQueryContinueParam(lp);
      SetDlgItemText( hwndDlg,   6, PChar(strYes) );
      SetDlgItemText( hwndDlg,   2, PChar(strNo) );
      SetDlgItemText( hwndDlg, 102, PChar(strYesToAll) );
      SetDlgItemText( hwndDlg, 103, PChar(strError+' :') );
      SetDlgItemText( hwndDlg, 106, PChar(strFile+' :') );
      SetDlgItemText( hwndDlg, 108, PChar(strCanContinue) );
      SetWindowText( hwndDlg, PChar(strConfirmation) );
      SetWindowLong( hwndDlg, DWL_USER, lp );
      CenterWindow( hwndDlg );
      with pparams^ do
        begin
          SetDlgItemText( hwndDlg, 104, PChar(ErrorMsg) );
          SetDlgItemText( hwndDlg, 105, PChar(FileName) );
          SetDlgItemText( hwndDlg, 107, PChar(Format('%.0n bytes  %s',[FileSize*1.0, DateTimeToStr(FileDate)])) );
        end;
    end;
  WM_CLOSE, WM_QUIT:
    begin
      EndDialog( hwndDlg, 0 );
      Result := True;
    end;
  WM_COMMAND:
    begin
      EndDialog( hwndDlg, wp );
      Result := True;
    end;
  end;
end;

function QueryContinue( const ErrorMsg, FileName : String;
                        FileSize : Integer;
                        FileDate : TDateTime ) : Integer;
var
  params : TQueryContinueParams;
begin
  params.ErrorMsg := ErrorMsg;
  params.FileName := FileName;
  params.FileSize := FileSize;
  params.FileDate := FileDate;
  Result := DialogBoxParam(
     hInstance,                // handle of application instance
     MakeIntResource(104),     // identifies dialog box template
     GetActiveWindow,          // handle of owner window
     @QueryContinueProc,       // address of dialog box procedure
     Integer(@params)          // initialization value
    );
end;

/////////////////////////////////////////
// Misc functions
/////////////////////////////////////////

function ReadInteger( S : TStream ) : Integer;
begin
  S.ReadBuffer( Result, Sizeof(Result) );
end;

procedure WriteInteger( S : TStream; val : Integer );
begin
  S.WriteBuffer( val, Sizeof(val) );
end;

function ReadWord( S : TStream ) : Word;
begin
  S.ReadBuffer( Result, Sizeof(Result) );
end;

procedure WriteWord( S : TStream; val : Word );
begin
  S.WriteBuffer( val, Sizeof(val) );
end;

function ReadFloat( S : TStream ) : Extended;
begin
  S.ReadBuffer( Result, Sizeof(Result) );
end;

procedure WriteFloat( S : TStream; val : Extended );
begin
  S.WriteBuffer( val, Sizeof(val) );
end;

function ReadBoolean( S : TStream ) : Boolean;
begin
  S.ReadBuffer( Result, Sizeof(Result) );
end;

procedure WriteBoolean( S : TStream; val : Boolean );
begin
  S.WriteBuffer( val, Sizeof(val) );
end;


function ReadString( S : TStream ) : String;
var
  len : Integer;
begin
  len := ReadInteger(S);
  SetString(Result, PChar(nil), len);
  S.ReadBuffer(Pointer(Result)^, len);
end;

procedure WriteString( S : TStream; val : String );
begin
  WriteInteger( S, Length(val) );
  S.WriteBuffer(Pointer(val)^, Length(val));