Chip 2002 March/Chip_2002-03_cd1.bin/zkuste/delphi/kompon/d5/cak/CAKINST.ZIP/cmarc139.lzh/DEMOCB.LZH/LHPRGDLG.PAS

Pascal/Delphi Source File | 2001-05-27 | 14.1 KB | 468 lines

// ô¥ìçâAü[âJâCâoâRâôâ|ü[âlâôâg for Delphi/C++Builder
// Common Archivers Component for Delphi/C++Builder
// Copyright(C) NORG1964/M.Yoneda 1997,1998,1999,2000
//
// UNLHA32.DLLòù îoë▀ò\Īâ_âCâAâìâO  LHPRGDLG.PAS
//
// v1.27:âfâéé╔é▒é╠âéâWâàü[âïé≡Æ╟ë┴
// v1.32:UnpackFiles/PackFiles/RemoveItemsé╚é╟é╠âüâ\âbâhé≡Æ╟ë┴
// v1.36:é▒é╠âtâHü[âÇé╠ò\Īé╔ ShowModal é≡Ägéñéµéñé╔é╡é╜üB
//       â_âCâAâìâOâCâôâXâ^âôâXé≡É╢ɼé╡é─Ägùpé╖éΘ(ìLï`é╠)âüâ\âbâhé≡Æ╟ë┴
//
unit LHPRGDLG;

interface

uses
    Windows,
    Messages,
    SysUtils,
    Classes,
    Graphics,
    Controls,
    Forms,
    Dialogs,
    StdCtrls,
    ComCtrls,
    Archives;

const
    WM_EXECMETHOD = WM_USER+100;

type
    TArchiverMethod = function:Integer of object;
    TArchiverMethodAndParams = class
        private
            FMethod:                TArchiverMethod;
            FArchiveFIle:        TArchiveFIle;
            FOptions:            TArchiverOptions;
            FBaseDir:            string;
            FFileList:            TStringList;
            FBuffer:                Pointer;
            FdwBuffSize:        DWORD;
            FArchiverResult:    integer;
        public
            constructor Create( Method:TArchiverMethod;ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:string;FileList:array of const;Buffer:Pointer;dwBuffSize:DWORD );
            destructor Destroy; override;
            procedure ExecMethod;
        public
            dwWriteSize:        DWORD;
        public
            property ArchiveFile:        TArchiveFile        read FArchiveFile;
            property Options:                TArchiverOptions    read FOptions;
            property BaseDir:                string                read FBaseDir;
            property FileList:            TStringList            read FFileList;
            property Buffer:                Pointer                read FBuffer;
            property dwBuffSize:            DWORD                    read FdwBuffSize;
            property ArchiverResult:    integer                read FArchiverResult;
    end;

    TdlgArchiverProgress = class( TForm )
        ProgressBar1:            TProgressBar;
        cmdCancel:                TButton;
        lblArchiveFileName:    TLabel;
        lblSrcFileName1:        TLabel;
        lblSrcFileName2:        TLabel;
        lblWriteSize:            TLabel;
        lblCount:                TLabel;
        Label1:                    TLabel;
        Label3:                    TLabel;
        Label5:                    TLabel;
        Label6:                    TLabel;
        Label4:                    TLabel;
        procedure FormShow( Sender:TObject );
        procedure cmdCancelClick( Sender:TObject );
        procedure ArchiveFileProgress( Sender:TObject;State:Integer;lpEis:LPEXTRACTINGINFOEX;var Abort:Boolean );

    private
        FFileCount1:            integer;
        FFileCount2:            integer;
        FFileCount3:            integer;
        FCanceled:                boolean;
        FOrgProgress:           TArchiverProgressEvent;
        procedure SetArchiveFileName( const Value:string );

    protected
        procedure DoShow; override;
        procedure DoHide; override;
        procedure BeforeExec( ArchiveFile:TArchiveFile );
        procedure AfterExec( ArchiveFile:TArchiveFile );

    private
        FArchiver:                TArchiverMethodAndParams;
        function DoUnpackFiles  :Integer;
        function DoPackFiles    :Integer;
        function DoRemoveItems  :Integer;
        function DoUpdateArchive:Integer;
        function DoMakeSfx      :Integer;
        function DoUnpackToMem  :Integer;
//        function DoCheckArchive :integer;
        procedure ExecMethod( var msg:TMessage ); message WM_EXECMETHOD;

    public
        property ArchiveFileName:    string write SetArchiveFileName;

        function UnpackFiles  ( ArchiveFile:TArchiveFile;Options:TArchiverOptions;DstPath:String;FileList:array of const ):Integer;
        function PackFiles    ( ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:String;FileList:array of const ):Integer;
        function RemoveItems  ( ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:String;FileList:array of const ):Integer;
        function UpdateArchive( ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:String;FileList:array of const ):Integer;
        function MakeSfx      ( ArchiveFile:TArchiveFile;Options:TArchiverOptions;DstPath:String ):Integer;
        function UnpackToMem  ( ArchiveFile:TArchiveFile;Options:TArchiverOptions;FileName:string;lpvBuffer:LPVOID;dwSize:DWORD;lpdwWriteSize:LPDWORD ):Integer;
    end;

var
    dlgArchiverProgress: TdlgArchiverProgress;

implementation

uses
    Filters;

{$OPTIMIZATION ON}    // é▒éΩé≡ôⁿéΩé╚éóé╞ C++ Builder 3 é┼îδô«ì∞
{$BOOLEVAL OFF}

{$IFNDEF VER90} // not Delphi 2 ?
    {$IFNDEF VER100} // not Delphi 3 ?
        {$HPPEMIT '#include "LHPRSTUB.h"'}
        {$ObjExportAll On}
    {$ENDIF}
{$ENDIF}

{$R *.DFM}

procedure TdlgArchiverProgress.FormShow( Sender:TObject );
begin
    PostMessage( Handle,WM_EXECMETHOD,0,0 );
end;

procedure TdlgArchiverProgress.ExecMethod;
begin
    BeforeExec( FArchiver.ArchiveFile );
    try
        FArchiver.ExecMethod;
    finally
        AfterExec( FArchiver.ArchiveFile );
        ModalResult := mrOk;
    end;
end;

procedure TDlgArchiverProgress.ArchiveFileProgress( Sender:TObject;State:Integer;lpEis:LPEXTRACTINGINFOEX;var Abort: Boolean );
begin
    Application.ProcessMessages;
    ABort := FCanceled;

    if lpEis = nil then exit;

    with lpEis^,lpEis^.exinfo do begin
        lblSrcFileName1.Caption := ExtractFileName( szSourceFileName );
        if State <> 5
        then begin
            lblSrcFileName2.Caption := szDestFileName;
            lblWriteSize   .Caption := IntToStr( dwWriteSize );
            if dwFileSize <> 0
            then ProgressBar1  .Position := dwWriteSize * 100 div dwFileSize
            else ProgressBar1  .Position := 0;
        end;
    end;

    case State of
        ARCEXTRACT_BEGIN:            // èYôûâtâ@âCâïé╠Åêù¥é╠èJÄn
            if FFileCount1 > 0
            then begin
                Inc( FFileCount2 );
                lblCount.Caption := '[' + IntToStr( FFileCount2 ) + '/' + IntToStr( FFileCount1 ) + ']';
            end else begin
                if FFileCount3 > 0
                then begin
                    Inc( FFileCount2 );
                    lblCount.Caption := '[' + IntToStr( FFileCount2 ) + '/' + IntToStr( FFileCount3 ) + ']';
                end;
            end;
        ARCEXTRACT_INPROCESS:    // èYôûâtâ@âCâïé╠ôWèJÆå
            ;
        ARCEXTRACT_COPY:            // âÅü[âNâtâ@âCâïé╠Åæé½û▀é╡
            begin
                Label4.Visible := False;
                Label5.Visible := True;
                lblSrcFileName2.Visible := False;
                cmdCancel.Enabled := False;
            end;
        ARCEXTRACT_END:            // Åêù¥ÅIù╣üAè╓ÿAâüâéâèé≡èJò·
            ;
        ARCEXTRACT_OPEN:            //    èYôûÅæî╔é╠Åêù¥é╠èJÄn
            ;
        5:                                // âAü[âJâCâo DLL é╔éµéΘâtâ@âCâïû╝Ä√ÅWÆåüH
            begin
            Inc( FFileCount1 );
            lblCount.Caption := '[' + IntToStr( FFileCount1 ) + ']';
            end;
        $805:                            // ôαòöâtâBâïâ^é╔éµéΘâtâ@âCâïû╝Ä√ÅWÆåüH
            begin
            Inc( FFileCount3 );
            lblCount.Caption := '[' + IntToStr( FFileCount3 ) + ']';
            end;
        6:                                // ê│Åké╠ÅΩìçé═üCé▒é╠âüâbâZü[âWé┼Äné▀é─æSé─é╠âüâôâoé¬ùLî°é╞é╚éΘ
            ;
    end;
end;

procedure TdlgArchiverProgress.BeforeExec( ArchiveFile:TArchiveFile );
begin
    FOrgProgress := ArchiveFile.OnProgress;
    ArchiveFile.OnProgress := ArchiveFileProgress;
    ArchiveFileName := ArchiveFile.FileName;
//    Show;
//    Update;
end;

procedure TdlgArchiverProgress.AfterExec( ArchiveFile:TArchiveFile );
begin
    ArchiveFile.OnProgress := FOrgProgress;
//    Hide;
end;

procedure TDlgArchiverProgress.DoShow;
begin
    FFileCount1 := 0;
    FFileCount2 := 0;
    FFileCount3 := 0;
    lblCount.       Caption := '';
    lblWriteSize   .Caption := '';
    lblSrcFileName2.Caption := '';
    lblSrcFileName2.Visible := True;
    Label4.Visible := True;
    Label5.Visible := False;
    ProgressBar1  .Position := 0;
    FCanceled := False;
    inherited;
end;

procedure TDlgArchiverProgress.DoHide;
begin
    cmdCancel.Enabled := True;
end;

procedure TDlgArchiverProgress.SetArchiveFileName( const Value:string );
begin
    lblArchiveFileName.Caption := Value;
end;

procedure TdlgArchiverProgress.cmdCancelClick( Sender:TObject );
begin
    FCanceled := True;
end;

function TdlgArchiverProgress.MakeSfx( ArchiveFile:TArchiveFile;Options:TArchiverOptions;DstPath:String ):Integer;
begin
    Assert( Self <> nil,'dlgArchiverProgress not assigned' );
    FArchiver := TArchiverMethodAndParams.Create( DoMakeSfx,ArchiveFile,Options,DstPath,[nil],nil,0 );
    try
        Caption        := 'Ä⌐î╚ë≡ôÇÅæî╔ì∞ɼ';
        Label4.Caption := 'ê│Åkâtâ@âCâïüF';
        ShowModal;
        Result := FArchiver.ArchiverResult;
    finally
        FArchiver.Free;
        FArchiver := nil;
    end;
end;

function TdlgArchiverProgress.PackFiles( ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:String;FileList:array of const ):Integer;
begin
    Assert( Self <> nil,'dlgArchiverProgress not assigned' );
    FArchiver := TArchiverMethodAndParams.Create( DoPackFiles,ArchiveFile,Options,BaseDir,FileList,nil,0 );
    try
        Caption        := 'ê│ÅkÅ≤ï╡';
        Label4.Caption := 'ê│Åkâtâ@âCâïüF';
        ShowModal;
        Result := FArchiver.ArchiverResult;
    finally
        FArchiver.Free;
        FArchiver := nil;
    end;
end;

function TdlgArchiverProgress.RemoveItems( ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:String;FileList:array of const ):Integer;
begin
    Assert( Self <> nil,'dlgArchiverProgress not assigned' );
    FArchiver := TArchiverMethodAndParams.Create( DoRemoveItems,ArchiveFile,Options,BaseDir,FileList,nil,0 );
    try
        Caption        := 'ìφÅ£Å≤ï╡';
        Label4.Caption := 'ìφÅ£âtâ@âCâïüF';
        ShowModal;
        Result := FArchiver.ArchiverResult;
    finally
        FArchiver.Free;
        FArchiver := nil;
    end;
end;

function TdlgArchiverProgress.UnpackFiles( ArchiveFile:TArchiveFile;Options:TArchiverOptions;DstPath:String;FileList:array of const ):Integer;
begin
    Assert( Self <> nil,'dlgArchiverProgress not assigned' );
    FArchiver := TArchiverMethodAndParams.Create( DoUnpackFiles,ArchiveFile,Options,DstPath,FileList,nil,0 );
    try
        Caption        := 'ë≡ôÇÅ≤ï╡';
        Label4.Caption := 'ë≡ôÇɵü@ü@ü@üF';
        ShowModal;
        Result := FArchiver.ArchiverResult;
    finally
        FArchiver.Free;
        FArchiver := nil;
    end;
end;

function TdlgArchiverProgress.UnpackToMem( ArchiveFile:TArchiveFile;Options:TArchiverOptions;FileName:string;lpvBuffer:LPVOID;dwSize:DWORD;lpdwWriteSize:LPDWORD ):Integer;
begin
    Assert( Self <> nil,'dlgArchiverProgress not assigned' );
    FArchiver := TArchiverMethodAndParams.Create( DoUnpackToMem,ArchiveFile,Options,'',[FileName],nil,0 );
    try
        Caption        := 'ë≡ôÇÅ≤ï╡';
        Label4.Caption := '';
        ShowModal;
        Result := FArchiver.ArchiverResult;
    finally
        FArchiver.Free;
        FArchiver := nil;
    end;
end;

function TdlgArchiverProgress.UpdateArchive( ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:String;FileList:array of const ):Integer;
begin
    Assert( Self <> nil,'dlgArchiverProgress not assigned' );
    FArchiver := TArchiverMethodAndParams.Create( DoUpdateArchive,ArchiveFile,Options,BaseDir,FileList,nil,0 );
    try
        Caption        := 'ê│ÅkÅ≤ï╡';
        Label4.Caption := 'ê│Åkâtâ@âCâïüF';
        ShowModal;
        Result := FArchiver.ArchiverResult;
    finally
        FArchiver.Free;
        FArchiver := nil;
    end;
end;

function TdlgArchiverProgress.DoUnpackFiles:Integer;
begin
    with FArchiver do Result := ArchiveFile.UnpackFiles( Handle,Options,BaseDir,[FileList] );
end;

function TdlgArchiverProgress.DoPackFiles:Integer;
begin
    with FArchiver do Result := ArchiveFile.PackFiles( Handle,Options,BaseDir,[FileList] );
end;

function TdlgArchiverProgress.DoRemoveItems:Integer;
begin
    with FArchiver do Result := ArchiveFile.RemoveItems( Handle,Options,BaseDir,[FileList] );
end;

function TdlgArchiverProgress.DoUpdateArchive:Integer;
begin
    with FArchiver do Result := ArchiveFile.UpdateArchive( Handle,Options,BaseDir,[FileList] );
end;

function TdlgArchiverProgress.DoMakeSfx:Integer;
begin
    with FArchiver do Result := ArchiveFile.MakeSfx( Handle,Options,BaseDir );
end;

function TdlgArchiverProgress.DoUnpackToMem:Integer;
begin
    with FArchiver do Result := ArchiveFile.UnpackToMem( Handle,Options,FileList[0],Buffer,dwBuffSize,@dwWriteSize );
end;

constructor TArchiverMethodAndParams.Create( Method:TArchiverMethod;ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:string;FileList:array of const;Buffer:Pointer;dwBuffSize:DWORD );
begin
    FMethod      := Method;
    FArchiveFile := ArchiveFIle;
    FOptions     := Options;
    FBaseDir     := BaseDir;
    FFileList    := ArrayToList( FileList );
    FBuffer      := Buffer;
    FdwBuffSize  := dwBuffSize;
end;

destructor TArchiverMethodAndParams.Destroy;
begin
    FFileList.Free;
    inherited;
end;

procedure TArchiverMethodAndParams.ExecMethod;
begin
    FArchiverResult := FMethod;
end;

function UnpackFiles( ArchiveFile:TArchiveFile;Options:TArchiverOptions;DstPath:String;FileList:array of const ):Integer;
var
    dlgArchiverProgress:    TdlgArchiverProgress;
begin
    dlgArchiverProgress := TdlgArchiverProgress.Create( Application );
    try
        Result := dlgArchiverProgress.UnpackFiles( ArchiveFile,Options,DstPath,FileList )
    finally
        dlgArchiverProgress.Free;
    end;
end;

function PackFiles( ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:String;FileList:array of const ):Integer;
var
    dlgArchiverProgress:    TdlgArchiverProgress;
begin
    dlgArchiverProgress := TdlgArchiverProgress.Create( Application );
    try
        Result := dlgArchiverProgress.PackFiles( ArchiveFile,Options,BaseDir,FileList )
    finally
        dlgArchiverProgress.Free;
    end;
end;

function RemoveItems( ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:String;FileList:array of const ):Integer;
var
    dlgArchiverProgress:    TdlgArchiverProgress;
begin
    dlgArchiverProgress := TdlgArchiverProgress.Create( Application );
    try
        Result := dlgArchiverProgress.RemoveItems( ArchiveFile,Options,BaseDir,FileList )
    finally
        dlgArchiverProgress.Free;
    end;
end;

function UpdateArchive( ArchiveFile:TArchiveFile;Options:TArchiverOptions;BaseDir:String;FileList:array of const ):Integer;
var
    dlgArchiverProgress:    TdlgArchiverProgress;
begin
    dlgArchiverProgress := TdlgArchiverProgress.Create( Application );
    try
        Result := dlgArchiverProgress.UpdateArchive( ArchiveFile,Options,BaseDir,FileList )
    finally
        dlgArchiverProgress.Free;
    end;
end;

function MakeSfx( ArchiveFile:TArchiveFile;Options:TArchiverOptions;DstPath:String ):Integer;
var
    dlgArchiverProgress:    TdlgArchiverProgress;
begin
    dlgArchiverProgress := TdlgArchiverProgress.Create( Application );
    try
        Result := dlgArchiverProgress.MakeSfx( ArchiveFile,Options,DstPath )
    finally
        dlgArchiverProgress.Free;
    end;
end;

function UnpackToMem( ArchiveFile:TArchiveFile;Options:TArchiverOptions;FileName:string;lpvBuffer:LPVOID;dwSize:DWORD;lpdwWriteSize:LPDWORD ):Integer;
begin
    dlgArchiverProgress := TdlgArchiverProgress.Create( Application );
    try
        Result := dlgArchiverProgress.UnpackToMem( ArchiveFile,Options,FileName,lpvBuffer,dwSize,lpdwWriteSize );
    finally
        dlgArchiverProgress.Free;
    end;
end;

end.