sevenzipvcl.pas

TSevenZipVCL v.0.73 By Rainer Geigenberger. Component / Wrapper to use the 7zip dll. Easy to us

    function Read( var Data; Size: DWORD; ProcessedSize: PDWORD ): Integer; stdcall;
    function ReadPart( var Data; Size: DWORD; ProcessedSize: PDWORD ): Integer; stdcall;
    function GetSize( var Size: Int64 ): Integer; stdcall;
  end;

// -----------------------------------------------------------------------------
  TMyArchiveUpdateCallback = class( TInterfacedObject, IArchiveUpdateCallback, ICryptoGetTextPassword2, IProgress )
    FSevenZip: TSevenZip;
    Files: TWideStringArray;//TStringList;
    Files_size: array of int64;
    Files_Date: array of TFiletime;
    Files_Attr: array of Cardinal;
    FProgressFile: Widestring;
    FProgressFilePos: int64;
    FprogressFileSize: int64;
    FLastPos: int64;
    RootDir: WideString;
    FPassword: WideString;
//    FIncludeDriveletter: Boolean;
    constructor Create( Owner: TSevenZip );
//    destructor destroy;
//    function EnumProperties( var enumerator: IEnumSTATPROPSTG ): Integer; stdcall;
    function GetUpdateItemInfo(
      index: DWORD;
      newData: PInteger; // 1 - new data, 0 - old data
      newProperties: PInteger; // 1 - new properties, 0 - old properties
      indexInArchive: PDWORD // -1 if there is no in archive, or if doesn't matter
    ): Integer; stdcall;
    function GetProperty( index: DWORD; propID: PROPID; value: PPROPVARIANT ): Integer; stdcall;
    function GetStream( index: DWORD; var inStream: ISequentialInStream ): Integer; stdcall;
    function SetOperationResult( operationResult: Integer ): Integer; stdcall;
// Shadow 29.11.2006
    function CryptoGetTextPassword2( passwordIsDefined: PInteger; var Password: PWideChar ): Integer; stdcall;
    function SetTotal( total: Int64 ): Integer; stdcall;
    function SetCompleted( const completeValue: PInt64 ): Integer; stdcall;
  end;

  TMyArchiveExtractCallback = class( TInterfacedObject, IArchiveExtractCallback, ICryptoGetTextPassword )
    FSevenzip: TSevenzip;
    FExtractDirectory: Widestring;
    FProgressFile: Widestring;
    FProgressFilePos: int64;
    FProgressFileSize: int64;
    FLastPos: int64;
    FFilestoextract: int64;
    FLastFileToExt: Boolean;
    FAllFilesExt: Boolean;
    FPassword: WideString;
    constructor Create( Owner: TSevenZip );
    function GetStream( index: DWORD; out outStream: ISequentialOutStream; askExtractMode: DWORD ): Integer; stdcall;
    // GetStream OUT: S_OK - OK, S_FALSE - skeep this file
    function PrepareOperation( askExtractMode: Integer ): Integer; stdcall;
    function SetOperationResult( resultEOperationResult: Integer ): Integer; stdcall;
    function SetTotal( total: Int64 ): Integer; stdcall;
    function SetCompleted( const completeValue: PInt64 ): Integer; stdcall;
// Shadow 29.11.2006
    function CryptoGetTextPassword( var Password: PWideChar ): Integer; stdcall;
  end;


  TMyArchiveOpenCallback = class( TInterfacedObject, IArchiveOpenCallback, ICryptoGetTextPassword )
    FSevenzip: TSevenzip;
    FPassword: WideString;
    constructor Create( Owner: TSevenZip );
    function SetTotal( const files: Int64; const bytes: Int64 ): Integer; stdcall;
    function SetCompleted( const files: Int64; const bytes: Int64 ): Integer; stdcall;
    function CryptoGetTextPassword( var Password: PWideChar ): Integer; stdcall;
  end;

//----------------------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------------------
//--------------END SevenZip Interface--------------------------------------------------------
//----------------------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------------------




//----------------------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------------------
//--------------Start SevenZip VCL -------------------------------------------------------------
//----------------------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------------------

//type
  TListfileEvent = procedure( Sender: TObject; Filename: Widestring; Fileindex,FileSizeU,FileSizeP,Fileattr,Filecrc:cardinal;Filemethod:Widestring ;FileTime:double ) of object;
  TExtractfileEvent = procedure( Sender: TObject; Filename: Widestring; Filesize:int64 ) of object;
  TAddFileEvent = procedure( Sender: TObject; Filename: Widestring; Filesize:int64 ) of object;
  TPreProgressEvent = procedure( Sender: TObject; MaxProgress: int64 ) of object;
  TProgressEvent = procedure( Sender: TObject; Filename: Widestring; FilePosArc,FilePosFile: int64 ) of object;
  TMessageEvent = procedure( Sender: TObject; ErrCode: Integer; Message: string;Filename:Widestring )  of object;
//  TCRC32ErrorEvent = procedure( Sender: TObject; ForFile: string;  FoundCRC, ExpectedCRC: LongWord; var DoExtract: Boolean ) of object;
//  TCommentEvent = procedure( Sender: TObject;Comment: string; ) of object;

// GDG 21.02.07 : added FileIndex to this event in case we're managing a list of files.
  TSetNewNameEvent = procedure( Sender: TObject; FileIndex: DWORD; var OldFileName: WideString ) of object;

  TExtractOverwrite = procedure( Sender: TObject; FileName: WideString; var DoOverwrite: Boolean ) of object;

//type
  TSevenZip = class( TComponent )       // Twincontrol   TComponent
  private
    FErrCode: Integer;
    FLastError:Integer;                                        //FHO 22.01.2007
    FHandle: HWND;
//    FMessage: Widestring; // Not used now ErikGG 08.11.06
    FExtrBaseDir: Widestring;
    FSevenZipFileName: Widestring;

    FComment: Widestring;
    FRootDir: Widestring;

    Ffiles: TWideStringList_;

    { Event variables }
    FOnProgress: TProgressEvent;
    FOnPreProgress: TPreProgressEvent;
    FOnMessage: TMessageEvent;
    FOnlistfile: TlistfileEvent;
    FOnextractfile: TextractfileEvent;
    FOnaddfile: TaddfileEvent;
    FOnSetAddName: TSetNewNameEvent;
    FOnSetExtractName: TSetNewNameEvent;
    FOnExtractOverwite: TExtractOverwrite;

    FAddOptions: Addopts;
    FExtractOptions: Extractopts;
    FNumberOfFiles: Integer;
    FIsSFX: Boolean;
    FSFXOffset: Int64;
    FSFXCreate: Boolean;
    FSFXModule: Widestring;
    FCompresstype: TCompresstype;
    FCompstrength: TCompressStrength;
    FLZMAStrength: TLZMAStrength;
    FPPMDSize: TPPMDSize;
    FPPMDMem: TPPMDMem;
    FMainCancel: Boolean;

// Shadow 28.11.2006
{$IFDEF UseRes7zdll}
    mp_MemoryModule: PBTMemoryModule;
    mp_DllData: Pointer;
    m_DllDataSize: Integer;
{$ELSE}                                                        //FHO 25.01.2007
    F7zaLibh: THandle;
{$ENDIF}

//{$IFDEF DynaLoadDLL}
    FCreateObject: TCreateObjectFunc;
//{$ENDIF}

    FVolumeSize: Integer;
    FOnOpenVolume: TOpenVolume;
    FPassword: WideString;
    FNamesOfVolumesWritten: TWideStringArray;                  //FHO 17.01.2007

    { Private "helper" functions }

//    procedure LogMessage( var msg: TMessage ); message 9999;
    procedure ResetCancel;
    function AppendSlash( sDir: widestring ): widestring;
    procedure SetVolumeSize( const Value: Integer );
    procedure SetSFXCreate( const Value: Boolean );
    function InternalGetIndexByFilename( FileToExtract:Widestring ): Integer;		//ZSA 21.02.2007
    procedure ClearNamesOfVolumeWritten;
    procedure SetLastError(const Value: Integer);                       //FHO 17.01.2007
  protected
    inA: IInArchive;
    outA: IOutArchive;
    sp: ISetProperties;
  public
    constructor Create( AOwner: TComponent ); override;
    destructor Destroy; override;

    { Public Properties ( run-time only ) }
    property Handle: HWND read fHandle write fHandle;
    property ErrCode: Integer read fErrCode write fErrCode;
    property LastError:Integer read FLastError write SetLastError;// FLastError;//FHO 22.01.2007
    property IsSFX: Boolean read FIsSFX write FIsSFX;
    property SFXOffset: int64 read FSFXOffset write FSFXOffset;

    property SevenZipComment: Widestring read Fcomment write FComment;
    property Files: TWideStringList_ read Ffiles write ffiles;
    property NamesOfVolumesWritten: TWideStringArray read FNamesOfVolumesWritten;  //FHO 17.01.2007

    { Public Methods }
    function Add: Integer;
    function Extract( TestArchive:Boolean=False ): Integer;
    function List: Integer;
    procedure Cancel;
    function GetIndexByFilename( FileToExtract:Widestring ): Integer;
    function SFXCheck( Fn:Widestring ): Boolean;
    function ConvertSFXto7z( Fn:Widestring ): boolean;
    function Convert7ztoSFX( Fn:Widestring ): boolean;
  published
    { Public properties that also show on Object Inspector }
    property AddRootDir: Widestring read FRootDir write FRootDir;
    property SFXCreate: Boolean read FSFXCreate write SetSFXCreate;
    property SFXModule: Widestring read FSFXModule write FSFXModule;
    property AddOptions: AddOpts read FAddOptions write FAddOptions;
    property ExtractOptions: ExtractOpts read FExtractOptions write FExtractOptions;
    property ExtrBaseDir: Widestring read FExtrBaseDir write FExtrBaseDir;
    property LZMACompressType: TCompresstype read FCompresstype write FCompresstype;
    property LZMACompressStrength: TCompressStrength read FCompstrength write FCompstrength;
    property LZMAStrength: TLZMAStrength read FLZMAStrength write FLZMAstrength;
    property LPPMDmem: TPPMDmem read FPPMDmem write FPPMDmem;
    property LPPMDsize: TPPMDsize read FPPMDsize write FPPMDsize;
    property SZFileName: Widestring read FSevenZipFileName write FSevenZipFilename;
    property NumberOfFiles: Integer read FNumberOfFiles write FNumberOfFiles;
// Shadow 29.11.2006
    property VolumeSize: Integer read FVolumeSize write SetVolumeSize;
    property Password: WideString read FPassword write FPassword;
    { Events }

    property OnListfile: TlistfileEvent read FOnlistfile write FOnlistfile;
    property OnAddfile: TaddfileEvent read FOnaddfile write FOnaddfile;
    property OnExtractfile: TextractfileEvent read FOnextractfile write FOnextractfile;
    property OnProgress: TProgressEvent read FOnProgress  write FOnProgress;
    property OnPreProgress: TPreProgressEvent read FOnPreProgress  write FOnPreProgress;
    property OnMessage: TMessageEvent read fOnMessage write fOnMessage;
    property OnSetAddName: TSetNewNameEvent read FOnSetAddName write FOnSetAddName;
    property OnSetExtractName: TSetNewNameEvent read FOnSetExtractName write FOnSetExtractName;
    property OnExtractOverwrite: TExtractOverwrite read FOnExtractOverwite write FOnExtractOverwite;
    property OnOpenVolume: TOpenVolume read FOnOpenVolume write FOnOpenVolume;
  end;


// jjw 18.10.2006 FCreateobject - function CreateObject( const clsid: PGUID; const iid: PGUID; out _out ): Integer; stdcall; external '7za.dll';
//{$IFNDEF DynaLoadDLL}
//function CreateObject( const clsid: PGUID; const iid: PGUID; out _out ): Integer; stdcall; external '7za.dll'
//{$ENDIF}

{$IFDEF UseLog}
function PropTypeToString( propType: Integer ): string;
function PropIDToString( propID: Integer ): string;
procedure Log( sz: string );
{$ENDIF}
function FileTimeToDateTime( const rFileTime: TFileTime; const Localize: Integer = 0 ): TDateTime;
procedure SortDWord( var A: array of DWord; iLo, iHi: DWord );
function DriveIsRemovable( Drive: WideString ): Boolean;
function TryStrToInt_( const S: string; out Value: Integer ): Boolean;

//Unicode procedures
function UppercaseW_( s:WideString ):Widestring;
function GetFileSizeandDateTime_Int64( fn: Widestring; var fs:int64; var ft:Tfiletime; var fa:Integer ): int64;
function FileExists_( fn: Widestring ): Boolean;
function createfile_(lpFileName:Pwidechar; Access:Cardinal; Share:Cardinal;SecAttr:PSecurityattributes;
                     CreationDisposition:Cardinal;Flags:Cardinal;Temp:Cardinal) : integer;

{$IFDEF RegisterInThisUnit}
procedure Register;
{$ENDIF}

var FMainhandle: HWND; //for debug messages
var isUnicode : Boolean;

implementation

uses
  Forms, CommDlg;

//--------------------------------------------------------------------------------------------------
//-------------------Start UniCode procedures-------------------------------------------------------
//--------------------------------------------------------------------------------------------------

function isEqualW( s1, s2: WideString ): Boolean;
var
  i: Integer;
begin
  Result := FALSE;
  if Length( s1 ) <> Length( s2 ) then Exit;
  for i := 1 to Length( s1 ) do if WideChar( s1[ i ] ) <> WideChar( s2[ i ] ) then Exit;
  Result := TRUE;
end;

function FileExists_( fn: Widestring ): Boolean;
var
 fs:int64;
 ft:Tfiletime;
 fa:Integer;
begin
 if isUnicode then
   Result := ( GetFileSizeandDateTime_Int64( fn,fs,ft,fa ) > -1 )
  else
   Result := fileexists(string(fn));
end;

function PrevDir( Path: WideString ): WideString;
var
  l: Integer;
begin
  l := Length( Path );
  if ( l > 0 ) and ( Path[ l ] = '\' ) then Dec( l );
  while Path[ l ] <> '\' do Dec( l );
  Result := Copy( Path, 1, l );
end;

function ClearSlash( Path: WideString ): WideString;
var
  l: Integer;
begin
  l := Length( Path );
  if Path[ l ] = '\' then Dec( l );
  Result := Copy( Path, 1, l );
end;

function DirectoryExistsW( const Directory: WideString ): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributesW( PWideChar( Directory ) );
  Result := ( Code <> -1 ) and ( FILE_ATTRIBUTE_DIRECTORY and Code <> 0 );
end;

//START function from TNTControls http://www.tntware.com/
function StrScanWide( const Str: PWideChar; Chr: WideChar ): PWideChar;
begin
  Result := Str;
  while Result^ <> Chr do
  begin
    if Result^ = #0 then
    begin
      Result := nil;
      Exit;
    end;
    Inc( Result );
  end;
end;

function LastDelimiterW( const Delimiters, S: WideString ): Integer;
var
  P: PWideChar;
begin
  Result := Length( S );
  P := PWideChar( Delimiters );
  while Result > 0 do
  begin
    if ( S[ Result ] <> #0 ) and ( StrScanWide( P, S[ Result ] ) <> nil ) then
      Exit;
    Dec( Result );
  end;
end;

function ChangeFileExtW( const FileName, Extension: WideString ): WideString;
var
  I: Integer;
begin
  I := LastDelimiterW( '.\:',Filename );