sevenzipvcl.pas

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

  if ( I = 0 ) or ( FileName[ I ] <> '.' ) then I := MaxInt;
  Result := Copy( FileName, 1, I - 1 ) + Extension;
end;

function ExtractFilePathW( const FileName: WideString ): WideString;
var
  I: Integer;
begin
  I := LastDelimiterW( '\:', FileName );
  Result := Copy( FileName, 1, I );
end;

function ExtractFileNameW( const FileName: WideString ): WideString;
var
  I: Integer;
begin
  I := LastDelimiterW( '\:', FileName );
  Result := Copy( FileName, I + 1, MaxInt );
end;

function ExtractFileExtW( const FileName: WideString ): WideString;
var
  I: Integer;
begin
  I := LastDelimiterW( '.\:', FileName );
  if ( I > 0 ) and ( FileName[ I ] = '.' ) then
    Result := Copy( FileName, I, MaxInt ) else
    Result := '';
end;
//END function from TNTControls http://www.tntware.com/

function GetFileSizeandDateTime_Int64( fn: Widestring; var fs:int64; var ft:Tfiletime; var fa:Integer ): int64;
var
  FindDataW: _Win32_Find_Dataw;
  FindDataA: _Win32_Find_DataA;
  SearchHandle: THandle;
begin
  //Result := 0;

  if isUnicode then
   SearchHandle := FindFirstFilew( PWideChar( fn ), FindDataW )
  else
    SearchHandle := FindFirstFile( PAnsiChar( Ansistring( fn ) ), FindDataA );

  if SearchHandle = INVALID_HANDLE_VALUE then
   begin
    Result := -1;
    fs := -1;
    fa := -1;
    ft.dwLowDateTime := 0;
    ft.dwHighDateTime := 0;
    exit;
   end;

  if isUnicode then
   begin
     LARGE_Integer( Result ).LowPart := FindDataW.nFileSizeLow;
     LARGE_Integer( Result ).HighPart := FindDataW.nFileSizeHigh;

     LARGE_Integer( fs ).LowPart := FindDataW.nFileSizeLow;
     LARGE_Integer( fs ).HighPart := FindDataW.nFileSizeHigh;

     ft.dwLowDateTime  := FinddataW.ftLastWriteTime.dwLowDateTime;
     ft.dwHighDateTime := FinddataW.ftLastWriteTime.dwHighDateTime;
     fa := FinddataW.dwFileAttributes;
   end
  else
   begin
     LARGE_Integer( Result ).LowPart := FindDataA.nFileSizeLow;
     LARGE_Integer( Result ).HighPart := FindDataA.nFileSizeHigh;

     LARGE_Integer( fs ).LowPart := FindDataA.nFileSizeLow;
     LARGE_Integer( fs ).HighPart := FindDataA.nFileSizeHigh;

     ft.dwLowDateTime  := FinddataA.ftLastWriteTime.dwLowDateTime;
     ft.dwHighDateTime := FinddataA.ftLastWriteTime.dwHighDateTime;
     fa := FinddataA.dwFileAttributes;
   end;
   
  Windows.FindClose( SearchHandle );
end;

function ForceDirectoriesW( Path: WideString; Attr: Word ): Boolean;
var
  E: EInOutError;
begin
  Result := TRUE;

  if Path = '' then begin
    E := EInOutError.Create( 'Unable to create directory' );
    E.ErrorCode := 3;
    raise E;
  end;

  Path := ClearSlash( Path );
  if DirectoryExistsW( Path ) then Exit;

  if ( Length( Path ) < 3 ) or DirectoryExistsw( Path )
    or ( ExtractFilePath( Path ) = Path ) then Exit; // avoid 'xyz:\' problem.

  Result := ForceDirectoriesW( PrevDir( Path ), 0 ) and CreateDirectoryW( PWideChar( Path ), nil );
  if Result and ( Attr > 0 ) then SetFileAttributesW( PWideChar( Path ), Attr );
end;

function UppercaseW_( s:WideString ):Widestring;
begin
  Result := S;
  if Length( Result ) > 0 then
    CharUpperBuffW( PWideChar( Result ), Length( Result ) );
end;

//--------------------------------------------------------------------------------------------------
//-------------------End UniCode procedures---------------------------------------------------------
//--------------------------------------------------------------------------------------------------

//--------------------------------------------------------------------------------------------------
//-------------------Start Twidestringlist_-----------------------------------------------------------
//--------------------------------------------------------------------------------------------------

procedure TWideStringList_.AddString( s: WideString );
var i:Longword;
begin
 i := length( WStrings );
 Setlength( WStrings,i+1 );
 WStrings[ i ] := s;
 Count := i+1;
end;

procedure TWideStringList_.RemoveString( s: WideString );
var
  i: LongWord;
  f: Boolean;
begin
  f := FALSE;
  s := UpperCase( s );
  for i := Low( WStrings ) to High( WStrings ) do begin
    if isEqualW( UppercaseW_( WStrings[ i ] ), s ) then begin
      f := TRUE;
      Break;
    end;
  end;
  if f then begin
    WStrings[ i ] := WStrings[ High( WStrings ) ];
    WStrings[ High( WStrings ) ] := '';
    SetLength( WStrings, Length( WStrings ) - 1 );
    Dec( Count );
  end;
end;


Procedure TWideStringList_.Clear;
begin
 Setlength( WStrings,0 );
 Count := 0;
end;

Constructor TWideStringList_.Create;
begin
 clear;
end;

//--------------------------------------------------------------------------------------------------
//-------------------END Twidestringlist_-------------------------------------------------------------
//--------------------------------------------------------------------------------------------------

//--------------------------------------------------------------------------------------------------
//  Start common functions
//------------------------------------------------------------------------------------------------

function createfile_(lpFileName:Pwidechar; Access:Cardinal; Share:Cardinal;SecAttr:PSecurityattributes;
                     CreationDisposition:Cardinal;Flags:Cardinal;Temp:Cardinal) : integer;
begin
if isUnicode then
 Result := createfilew(lpFilename,access,share,SecAttr,Creationdisposition,flags,temp)
else
 Result := createfilea(PAnsichar( AnsiString(lpFilename)),access,share,SecAttr,Creationdisposition,flags,temp)
end;

//some Delphi veriosn do not take the Int64 overload
function FileSeek(Handle: Integer; const Offset: Int64; Origin: Integer): Int64;
begin
  Result := Offset;
  Int64Rec(Result).Lo := SetFilePointer(THandle(Handle), Int64Rec(Result).Lo,@Int64Rec(Result).Hi, Origin);
end;

function TSevenZip.AppendSlash( sDir: widestring ): widestring;
begin
  if ( sDir <> '' ) and ( sDir[ Length( sDir ) ] <> '\' ) then
    Result := sDir + '\'
  else
    Result := sDir;
end;

procedure TSevenZip.SetVolumeSize( const Value: Integer );
begin
// Shadow 27.11.2006
  if not FSFXCreate then
    FVolumeSize := Value
  else begin
    if ( Value > 0 ) and ( Value < FSFXOffset ) then
      FVolumeSize := FSFXOffset + 7
    else FVolumeSize := Value;
  end;
end;

procedure TSevenZip.SetSFXCreate( const Value: Boolean );

  function FileSizeW( fn: WideString ): DWORD;
  var
    f: Integer;
  begin
    Result := 0;
    f := CreateFile_( PwideChar( fn ), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0 );
    if dword(f)=INVALID_HANDLE_VALUE then Exit;               //FHO  20.01.2007
    try
      Result := FileSeek( f, int64(0), soFromEnd );
    finally
      FileClose( f );
    end;
  end;
var
  s: Int64;
begin
// Shadow 27.11.2006
  FSFXCreate := FALSE;
  if Value then begin
    s := FileSizeW( FSFXModule );
    if ( s > 0 ) then begin // FileExists
      if ( ( FVolumeSize > 0 ) and ( FVolumeSize < s + 7 ) ) then FVolumeSize := s + 7;
      FSFXOffset := s;
      FSFXCreate := TRUE;
    end;
  end;
end;

function FileTimeToDateTime( const rFileTime: TFileTime; const Localize: Integer = 0 ): TDateTime;
var
  dOffset: Double;
  rWork: TFileTime;
begin
  // offset to or from local time
  if Localize > 0 then
    FileTimeToLocalFileTime( rFileTime, rWork )
  else if Localize < 0 then
    LocalFileTimeToFileTime( rFileTime, rWork )
  else begin
    rWork := rFileTime;
  end;

  dOffset := 0.0000001 * ( ( Int64( rWork.dwHighDateTime ) shl 32 ) or rWork.dwLowDateTime );
  dOffset := dOffset / ( 60 * 60 * 24 );
  Result := EncodeDate( 1601, 1, 1 ) + dOffset;
end;

procedure SortDWord( var A: array of DWord; iLo, iHi: DWord );
var
  Lo, Hi, Mid, T: DWord;
begin
    Lo := iLo;
    Hi := iHi;
    Mid := A[ ( Lo + Hi ) div 2 ];
    repeat
      while A[ Lo ] < Mid do Inc( Lo );
      while A[ Hi ] > Mid do Dec( Hi );
      if Lo <= Hi then
      begin
        T := A[ Lo ];
        A[ Lo ] := A[ Hi ];
        A[ Hi ] := T;
        Inc( Lo );
        if Hi > 0 then Dec( Hi ); //Using DWord and not Integers
      end;
    until Lo > Hi;
    if Hi > iLo then SortDWord( A, iLo, Hi );
    if Lo < iHi then SortDWord( A, Lo, iHi );
end;

function DriveIsRemovable( Drive: WideString ): Boolean;
var
  DT: Cardinal;
begin
  DT := GetDriveTypeW( PWideChar( Drive ) );
  Result := ( DT <> DRIVE_FIXED );
end;

function TryStrToInt_( const S: string; out Value: Integer ): Boolean;
var
   E: Integer;
begin
   Val( S, Value, E );
   Result := ( E = 0 );
end;


//------------------------------------------------------------------------------------------------
//  End common functions
//--------------------------------------------------------------------------------------------------

//--------------------------------------------------------------------------------------------------
//--------------------------------------------------------------------------------------------------
//-------------------Start SevenZip Interface -----------------------------------------------
//--------------------------------------------------------------------------------------------------
//--------------------------------------------------------------------------------------------------

function TInterfacedObject.QueryInterface( const IID: TGUID; out Obj ): HResult;
const
  E_NOINTERFACE = HResult( $80004002 );
begin
  if GetInterface( IID, Obj ) then
  begin
    Result := 0;
{$IFDEF UseLog}
    Log( 'INTERFACEOK:' + ClassName + ' ' + GUIDToString( IID ) );
{$ENDIF}
  end else
  begin
    Result := E_NOINTERFACE;
{$IFDEF UseLog}
    Log( '  NOINTERFACE: ' + ClassName + ' ' + GUIDToString( IID ) );
{$ENDIF}
  end;
end;

function TInterfacedObject._AddRef: Integer;
begin
  Result := InterlockedIncrement( FRefCount );
end;

function TInterfacedObject._Release: Integer;
begin
  Result := InterlockedDecrement( FRefCount );
  if Result = 0 then
    Destroy;
end;

procedure TInterfacedObject.AfterConstruction;
begin
// Release the constructor's implicit refcount
  InterlockedDecrement( FRefCount );
end;

procedure TInterfacedObject.BeforeDestruction;
begin
  //if RefCount <> 0 then Error( reInvalidPtr );
end;

// Set an implicit refcount so that refcounting
// during construction won't destroy the object.
class function TInterfacedObject.NewInstance: TObject;