Subversion Repositories autosfx

unit mainunit;

// demo5 of Delphi Zip - this simple program makes an .EXE archive

(************************************************************************

 Copyright (C) 2009, 2010  by Russell J. Peters, Roger Aelbrecht,

      Eric W. Engler and Chris Vleghert.

   This file is part of TZipMaster Version 1.9.

    TZipMaster is free software: you can redistribute it and/or modify

    it under the terms of the GNU Lesser General Public License as published by

    the Free Software Foundation, either version 3 of the License, or

    (at your option) any later version.

    TZipMaster is distributed in the hope that it will be useful,

    but WITHOUT ANY WARRANTY; without even the implied warranty of

    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public License

    along with TZipMaster.  If not, see <http://www.gnu.org/licenses/>.

    contact: problems@delphizip.org (include ZipMaster in the subject).

    updates: http://www.delphizip.org

    DelphiZip maillist subscribe at http://www.freelists.org/list/delphizip

************************************************************************)

{$INCLUDE '..\..\ZipVers19.inc'}

{$IFDEF VERD6up}

{$WARN UNIT_PLATFORM OFF}

{$WARN SYMBOL_PLATFORM OFF}

{$ENDIF}

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  StdCtrls, Grids, ExtCtrls, {SortGrid,} ZipMstr19, ShlObj;

type

  TMainform = class( TForm )

    Panel1:       TPanel;

    Panel2:       TPanel;

    Panel3:       TPanel;

    Panel4:       TPanel;

    Bevel1:       TBevel;

    Bevel2:       TBevel;

    Label1:       TLabel;

    Label2:       TLabel;

    ZipFName:     TLabel;

    FilesLabel:   TLabel;

    DeleteZipBut: TButton;

    NewZipBut:    TButton;

    CloseBut:     TButton;

    DeleteBut:    TButton;

    AddBut:       TButton;

    StringGrid1:  TStringGrid;

    OpenDialog1:  TOpenDialog;

    ZipMaster1: TZipMaster19;

    procedure CloseButClick( Sender: TObject );

    procedure NewZipButClick( Sender: TObject );

    procedure DeleteZipButClick( Sender: TObject );

    procedure ZipMaster1DirUpdate( Sender: TObject );

    procedure FormCreate( Sender: TObject );

    procedure FillGrid;

    procedure AddButClick( Sender: TObject );

    procedure ZipMaster1Message( Sender: TObject; ErrCode: Integer; Message: string );

    procedure DeleteButClick( Sender: TObject );

    procedure FormDestroy( Sender: TObject );

  private

    { Private declarations }

  public

    { Public declarations }

    DoIt:     Boolean;

    FirstDir: String;

    procedure SetZipFName( aCaption: String );

    function  GetSpecialFolder( aFolder: Integer; var Location: String ): LongWord;

  end;

var

  Mainform: TMainform;

  Cancelled: Boolean;

implementation

uses addunit;

{$R *.DFM}

//{$R 'Res\dzsfx_all.res'}  // bin files

procedure TMainform.CloseButClick( Sender: TObject );

begin

   Close;

end;

procedure TMainform.NewZipButClick( Sender: TObject );

begin

   if FirstDir = '' then

      GetSpecialFolder( CSIDL_DESKTOPDIRECTORY, FirstDir );

   with OpenDialog1 do

   begin

      Title      := 'Create New EXE File';

      Options    := Options + [ofHideReadOnly,ofShareAware];

      Options    := Options - [ofPathMustExist,ofFileMustExist];

      Filter     := 'EXE Files (*.EXE)|*.exe';

      InitialDir := FirstDir;

      FileName   := '';

      if NOT Execute then

         Exit;

      FirstDir := ExtractFilePath( FileName );

      if Pos( '.', Filename ) = 0 then

         // user did not specify extension

         FileName := FileName + '.exe'

      else

         if Uppercase( ExtractFileExt( Filename ) ) <> '.EXE' then

         begin

            ShowMessage( 'Error: your new archive must end in .EXE' );

            Exit;

         end;

      if FileExists( FileName ) then

      begin

         if MessageDlg( 'Overwrite Existing File: ' + FileName + '?',

                       mtConfirmation, [mbYes,mbNo], 0 ) = mrYes then

            DeleteFile( FileName )

         else

            Exit;  { Don't use the new name }

      end;

      SetZipFName( Filename );

   end; { end with }

  if MessageDlg( 'Protect the archive with a password?', mtConfirmation,[mbYes,mbNo],0) = mrYes then

  begin

          ZipMaster1.Password := ZipMaster1.GetAddPassword;

      if ZipMaster1.Password = '' then

      begin

         { The 2 password's entered by user didn't match. }

         { We'll give him one more try }

         if MessageDlg( 'Do you want another chance to enter the password?',

            mtConfirmation, [mbYes,mbNo], 0 ) = mrYes then

                 begin

                        ZipMaster1.Password := ZipMaster1.GetAddPassword;

            if ZipMaster1.Password = '' then

               Close;

         end

         else

            Close;

      end;

  end;

  ZipMaster1.ZipFileName := ZipFName.Caption;

end;

procedure TMainform.DeleteZipButClick( Sender: TObject );

var

   ans: Boolean;

begin

   if FileExists( ZipFName.Caption ) then

   begin

      Ans:=MessageDlg('Are you sure you want to delete: ' + ZipFName.Caption

            + '?', mtConfirmation, [mbYes,mbNo], 0) = mrYes;

      if Ans then

      begin

         DeleteFile( ZipFName.Caption );

         SetZipFName( '<none>' );

         StringGrid1.RowCount := 2; { empty }

         StringGrid1.Rows[1].Clear;

         ZipMaster1.ZipFilename := '';

         FilesLabel.Caption := '0';

      end

      else

         Exit;  { Don't use the new name }

   end

   else

      ShowMessage( 'File not found: ' + ZipFName.Caption );

end;

procedure TMainform.ZipMaster1DirUpdate( Sender: TObject );

begin

   FillGrid;

   FilesLabel.Caption:=IntToStr( ZipMaster1.Count );

   SetZipFName( ZipMaster1.ZipFilename );

end;

procedure TMainform.FormCreate( Sender: TObject );

begin

  chdir( 'C:\' );

  with StringGrid1 do

  begin

    { Make sure "goColMoving" is false in object inspector. This lets the

      TSortGrid use Mouse Clicks on the col headers. }

    RowCount     :=   2;  { first row is fixed, and used for column headers }

    Cells[0,0]   := 'File Name';

    Cells[1,0]   := 'Compr Size';

    Cells[2,0]   := 'Uncmpr Size';

    Cells[3,0]   := 'Date/Time';

    ColWidths[0] := 316;

    ColWidths[1] :=  84;

    ColWidths[2] :=  94;

    ColWidths[3] := 120;

  end;

  ZipMaster1.Dll_Load := true;

//  ZipMaster1.Load_Zip_Dll;

end;

procedure TMainform.FormDestroy( Sender: TObject );

begin

  ZipMaster1.Dll_Load := false;

//  ZipMaster1.Unload_Zip_Dll;

end;

procedure TMainForm.FillGrid;

var

  i: Integer;

begin

  with StringGrid1 do

  begin

    { remove everything from grid except col titles }

    RowCount := 2;

    Rows[1].Clear;

    if ZipMaster1.Count = 0 then

       Exit;

    StringGrid1.RowCount := ZipMaster1.Count + 1;

    for i := 1 to ZipMaster1.Count do

    begin

//       with ZipDirEntry( ZipMaster1.ZipContents[i - 1]^ ) do  // old

           with ZipMaster1.DirEntry[i - 1]{^} do        // new

       begin

          Cells[0, i] := FileName;

          Cells[1, i] := IntToStr( CompressedSize );

          Cells[2, i] := IntToStr( UncompressedSize );

          Cells[3, i] := FormatDateTime( 'ddddd  t', FileDateToDateTime( DateTime ) );

       end; // end with

    end; // end for

  end; // end with

end;

procedure TMainform.AddButClick( Sender: TObject );

var

   IsOne: String;

begin

   { In this program, the first Add will cause the SFX code to be added,

     and will make the SFX control block.  So, we need to set the SFX

     properties now! }

   ZipMaster1.SFXDefaultDir := 'C:\'; // default extract directory

   if ZipMaster1.ZipFileName = '' then

   begin

      ShowMessage( 'Error - create a new archive first' );

      Exit;

   end;

   AddForm.Left   := Left;

   AddForm.Top    := Top;

   AddForm.Width  := Width;

   AddForm.Height := Height;

   Cancelled      := False;

   AddForm.ShowModal;  { let user pick filenames to add }

   if Cancelled then

      Exit;

   if AddForm.SelectedList.Items.Count = 0 then

   begin

      ShowMessage( 'No files selected' );

      Exit;

   end;

   with ZipMaster1 do

   begin

      Verbose    := False;

      Trace      := False;

      AddOptions := [];

      if Password > '' then

         AddOptions := AddOptions + [AddEncrypt]  { we want a password }

      else

         AddOptions := AddOptions - [AddEncrypt]; // don't forget to turn this off!

      FSpecArgs.Clear;

      FSpecArgs.Assign( AddForm.SelectedList.Items ); { specify filenames }

      AddForm.SelectedList.Clear;

      Screen.Cursor := crHourGlass;

      try

         Add;

      except

         Screen.Cursor := crDefault;

         ShowMessage( 'Error in Add; Fatal DLL Exception in mainunit' );

      end;

      Screen.Cursor := crDefault;

      if SuccessCnt = 1 then

         IsOne := ' was'

      else

         IsOne := 's were';

      ShowMessage( IntToStr( SuccessCnt ) + ' file' + IsOne + ' added' );

   end; { end with }

end;

// This is the "OnMessage" event handler

procedure TMainform.ZipMaster1Message( Sender: TObject; ErrCode: Integer; Message: string );

begin

   if ErrCode > 0 then

      ShowMessage( 'Error Msg from DLL: ' + Message );

end;

procedure TMainform.DeleteButClick( Sender: TObject );

var

   i:     Integer;

   Ans:   Boolean;

   IsOne: String;

begin

   with StringGrid1 do

   begin

      if ZipMaster1.Count < 1 then

      begin

         ShowMessage( 'Error - no files to delete' );

         Exit;

      end;

      Ans:=MessageDlg( 'Delete selected files from: ' + ZipMaster1.ZipFileName + '?',

               mtConfirmation, [mbYes, mbNo], 0 ) = mrYes;

      if not Ans then

         Exit;

      ZipMaster1.FSpecArgs.Clear;

      for i := Selection.Top to Selection.Bottom do

      begin

         ZipMaster1.FSpecArgs.Add( Cells[0, i] );

      end; { end for }

      if ZipMaster1.FSpecArgs.Count < 1 then

      begin

         ShowMessage( 'Error - no files selected' );

         Exit;

      end;

   end; { end with }

   ZipMaster1.Verbose := False;

   ZipMaster1.Trace   := False;

   Screen.Cursor := crHourGlass;

   try

      ZipMaster1.Delete;

   except

      Screen.Cursor := crDefault;

      ShowMessage( 'Fatal error trying to delete' );

   end;

   Screen.Cursor := crDefault;

   if ZipMaster1.SuccessCnt = 1 then

      IsOne := ' was'

   else

      IsOne := 's were';

   ShowMessage( IntToStr( ZipMaster1.SuccessCnt ) + ' file' + IsOne + ' deleted' );

end;

procedure TMainform.SetZipFName( aCaption: String );

begin

   ZipFName.Caption := aCaption;

   Font.Assign( ZipFName.Font );

   if Canvas.TextWidth( aCaption ) > ZipFName.Width then

   begin

      ZipFName.Hint     := aCaption;

      ZipFName.ShowHint := True;

   end

   else

      ZipFName.ShowHint := False;

end;

//---------------------------------------------------------------------------

{* Folder types are a.o.

 *      CSIDL_DESKTOPDIRECTORY, CSIDL_STARTMENU, CSIDL_SENDTO,

 * CSIDL_PROGRAMS, CSIDL_STARTUP etc.

 *}

function TMainform.GetSpecialFolder( aFolder: Integer; var Location: String ): LongWord;

var

   pidl:      PItemIDList;

   hRes:      HRESULT;

   RealPath:  Array[0..MAX_PATH] of Char;

   Success:   Boolean;

begin

   Result := 0;

   hRes   := SHGetSpecialFolderLocation( Handle, aFolder, pidl );

   if hRes = NO_ERROR then

   begin

      Success := SHGetPathFromIDList( pidl, RealPath );

      if Success then

         Location := String( RealPath ) + '\'

      else

         Result := LongWord( E_UNEXPECTED );

      GlobalFreePtr( pidl );

   end else

      Result := hRes;

end;

end.