Subversion Repositories recyclebinunit

unit RecBinUnit2 platform;

 

 

 

 

 

 

 

  Windows, SysUtils, Classes, ContNrs, ShellAPI, Registry, Messages, Math;

 

  RECBINUNIT_VERSION = '2022-06-30';

 

  RECYCLER_CLSID: TGUID = '{645FF040-5081-101B-9F08-00AA002F954E}';

  NULL_GUID:      TGUID = '{00000000-0000-0000-0000-000000000000}';

 

  EAPICallError = class(Exception);

  EEventCategoryNotDefined = class(Exception);

  EInvalidDrive = class(Exception);

 

  PSHQueryRBInfo = ^TSHQueryRBInfo;

  TSHQueryRBInfo = packed record

    cbSize      : DWORD;

    i64Size     : int64;

    i64NumItems : int64;

  end;

 

  TRbRecycleBinItem = class(TObject)

  strict private

    function GetSource: string;

  strict protected

    FSourceAnsi: AnsiString;

    FSourceUnicode: WideString;

    FID: string;

    FSourceDrive: Char;

    FDeletionTime: TDateTime;

    FOriginalSize: int64;

    FIndexFile: string;

    FRemovedEntry: boolean;

    procedure ReadFromStream(stream: TStream); virtual; abstract;

    function GetPhysicalFile: string; virtual; abstract; // protected, because it will be read by "property"

  public

    property PhysicalFile: string read GetPhysicalFile;

    property SourceAnsi: AnsiString read FSourceAnsi;

    property SourceUnicode: WideString read FSourceUnicode;

    property Source: string read GetSource; // will bei either ANSI or Unicode, depending on the Delphi version

    property ID: string read FID;

    property SourceDrive: Char read FSourceDrive;

    property DeletionTime: TDateTime read FDeletionTime;

    property OriginalSize: int64 read FOriginalSize;

    property IndexFile: string read FIndexFile;

    property RemovedEntry: boolean read FRemovedEntry; // the file is NOT in the recycle bin anymore!

 

    // Attention: There are no official API calls. The delete and recover

    // functions might fail and/or damage the shell cache. Handle with care!

    function DeleteFile: boolean; virtual; abstract;

    function RecoverFile: boolean; virtual; abstract;

    function OpenFile: boolean; virtual; abstract;

  end;

 

  TRbInfoAItem = class(TRbRecycleBinItem)

  strict protected

    procedure ReadFromStream(stream: TStream); override;

    function GetPhysicalFile: string; override;

  public

    constructor Create(fs: TStream; AIndexFile: string);

    function DeleteFile: boolean; override;

    // TODO: function RecoverFile: boolean; override;

    // TODO: function OpenFile: boolean; override;

  end;

 

  TRbInfoWItem = class(TRbRecycleBinItem)

  strict protected

    procedure ReadFromStream(stream: TStream); override;

    function GetPhysicalFile: string; override;

  public

    constructor Create(fs: TStream; AIndexFile: string);

    function DeleteFile: boolean; override;

    // TODO: function RecoverFile: boolean; override;

    // TODO: function OpenFile: boolean; override;

  end;

 

  TRbVistaItem = class(TRbRecycleBinItem)

  strict protected

    procedure ReadFromStream(stream: TStream); override;

    function GetPhysicalFile: string; override;

  public

    constructor Create(fs: TStream; AIndexFile, AID: string);

    function DeleteFile: boolean; override;

    // TODO: function RecoverFile: boolean; override;

    // TODO: function OpenFile: boolean; override;

  end;

 

  TRbRecycleBin = class(TObject)

  strict private

    FFileOrDirectory: string;

    FSID: string;

    FTolerantReading: boolean;

  public

    constructor Create(AFileOrDirectory: string; ASID: string='');

 

    function GetItem(id: string): TRbRecycleBinItem;

    procedure ListItems(list: TObjectList{TRbRecycleBinItem});

    function CheckIndexes(slErrors: TStrings): boolean;

 

    property FileOrDirectory: string read FFileOrDirectory;

    property SID: string read FSID;

 

    // Allows an index file to be read, even if an incompatible multiboot combination

    // corrupted it. Default: true.

    property TolerantReading: boolean read FTolerantReading write FTolerantReading;

  end;

 

  // TODO: Wie sieht es aus mit Laufwerken, die nur als Mount-Point eingebunden sind?

  TRbDrive = class(TObject)

  strict private

    FDriveLetter: AnsiChar;

 

    function OldCapacityPercent(var res: integer): boolean; // in % (0-100)

    function NewCapacityAbsolute(var res: integer): boolean; // in MB

 

    function DiskSize: integer; // in MB

    function DriveNumber: integer;

  strict protected

    function IsFAT: boolean;

    procedure CheckDriveExisting;

 

    // will return NULL_GUID in case of an error or if it is not supported

    function GetVolumeGUID: TGUID;

    function GetVolumeGUIDAvailable: boolean;

 

    // TODO: get drive serial

  public

    constructor Create(ADriveLetter: AnsiChar);

 

    // Wenn UserSID='', dann werden alle Recycler gefunden

    procedure ListRecycleBins(list: TObjectList{TRbRecycleBin}; UserSID: string='');

 

    property DriveLetter: AnsiChar read FDriveLetter;

    property VolumeGUID: TGUID read GetVolumeGUID;

    property VolumeGUIDAvailable: boolean read GetVolumeGUIDAvailable;

    function GetAPIInfo: TSHQueryRBInfo;

    function GetSize: int64;

    function GetNumItems: int64;

    function IsEmpty: boolean;

 

    function GetMaxPercentUsage: Extended; // 0..1

    function GetMaxAbsoluteUsage: integer; // in MB

    function GetNukeOnDelete: boolean;

  end;

 

  GPOLICYBOOL = (gpUndefined, gpEnabled, gpDisabled);

 

  TRecycleBinManager = class(TObject)

  public

    class procedure ListDrives(list: TObjectList{TRbDrive}); static;

    class function RecycleBinPossible(Drive: AnsiChar): boolean; static;

 

    class function OwnRecyclersSize: int64; static;

    class function OwnRecyclersNumItems: int64; static;

    class function OwnRecyclersEmpty: boolean; static;

 

    class function EmptyOwnRecyclers(flags: cardinal): boolean; overload; static;

    class function EmptyOwnRecyclers(sound, progress, confirmation: boolean): boolean; overload; static;

 

    class function RecyclerGetCurrentIconString: string; static;

    class function RecyclerGetDefaultIconString: string; static;

    class function RecyclerGetEmptyIconString: string; static;

    class function RecyclerGetFullIconString: string; static;

 

    class function GetGlobalMaxPercentUsage: integer; static; // TODO: In Win Vista: absolute and not relative sizes

    class function GetGlobalNukeOnDelete: boolean; static;

    class function UsesGlobalSettings: boolean; static;

 

    class function RecyclerGetName: string; static;

    class function RecyclerGetInfoTip: string; static;

    class function RecyclerGetIntroText: string; static;

 

    class function RecyclerEmptyEventGetCurrentSound: string; static;

    class function RecyclerEmptyEventGetDefaultSound: string; static;

    class function RecyclerEmptyEventGetName: string; static;

    class function RecyclerEmptyEventGetSound(ACategory: string): string; static;

    class procedure RecyclerEmptyEventGetSoundCategories(AStringList: TStringList); static;

 

    // TODO: In future also detect for other users

    // TODO: Also make a setter (incl. Message to Windows Explorer?)

    class function RecyclerGroupPolicyConfirmFileDelete: GPOLICYBOOL; static;

    class function RecyclerGroupPolicyNoRecycleFiles: GPOLICYBOOL; static;

    class function RecyclerGroupPolicyRecycleBinSize: integer; static;

 

    class function RecyclerConfirmationDialogEnabled: boolean; static;

    class procedure RecyclerConfirmationDialogSetEnabled(NewSetting: boolean); static;

    class function RecyclerShellStateConfirmationDialogEnabled: boolean; static;

 

    // Diese Funktion ist false, wenn sie z.B. unter Windows 95 ohne Internet Explorer

    // 4.0 Shell Extension ausgeführt wird. Wenn abwärtskompatibler Code geschrieben

    // werden soll, sollte RecyclerQueryFunctionAvailable() verwendet werden, da

    // unter Windows 95 folgende Funktionalitäten NICHT vorhanden sind:

    // - RecyclerIsEmpty

    // - RecyclerGetNumItems

    // - RecyclerGetSize

    // - RecyclerGetAPIInfo

    class function RecyclerQueryFunctionAvailable: boolean; static;

 

    class function RecyclerAddFileOrFolder(FileOrFolder: string; confirmation: boolean=false): boolean; static;

  end;

 

function GPBoolToString(value: GPOLICYBOOL): string;

 

 

  RecBinUnitLowLvl;

 

 

  SHELLSTATE = record

    Flags1: DWORD;

 

    dwWin95Unused: DWORD; // Win95 only - no longer supported pszHiddenFileExts

    uWin95Unused: UINT; // Win95 only - no longer supported cbHiddenFileExts

 

    // Note: Not a typo!  This is a persisted structure so we cannot use LPARAM

    lParamSort: Integer;

    iSortDirection: Integer;

 

    version: UINT;

 

    // new for win2k. need notUsed var to calc the right size of ie4 struct

    // FIELD_OFFSET does not work on bit fields

    uNotUsed: UINT; // feel free to rename and use

    Flags2: DWORD;

  end;

  LPSHELLSTATE = ^SHELLSTATE;

 

  // Masks for the SHELLSTATE

  SSF_SHOWALLOBJECTS       = $00000001;

  SSF_SHOWEXTENSIONS       = $00000002;

  SSF_HIDDENFILEEXTS       = $00000004;

  SSF_SERVERADMINUI        = $00000004;

  SSF_SHOWCOMPCOLOR        = $00000008;

  SSF_SORTCOLUMNS          = $00000010;

  SSF_SHOWSYSFILES         = $00000020;

  SSF_DOUBLECLICKINWEBVIEW = $00000080;

  SSF_SHOWATTRIBCOL        = $00000100;

  SSF_DESKTOPHTML          = $00000200;

  SSF_WIN95CLASSIC         = $00000400;

  SSF_DONTPRETTYPATH       = $00000800;

  SSF_SHOWINFOTIP          = $00002000;

  SSF_MAPNETDRVBUTTON      = $00001000;

  SSF_NOCONFIRMRECYCLE     = $00008000;

  SSF_HIDEICONS            = $00004000;

  SSF_FILTER               = $00010000;

  SSF_WEBVIEW              = $00020000;

  SSF_SHOWSUPERHIDDEN      = $00040000;

  SSF_SEPPROCESS           = $00080000;

  SSF_NONETCRAWLING        = $00100000;

  SSF_STARTPANELON         = $00200000;

  SSF_SHOWSTARTPAGE        = $00400000;

 

  LNG_API_CALL_ERROR = 'Error while calling the API. Additional information: "%s".';

  LNG_NOT_CALLABLE = '%s not callable';

  LNG_ERROR_CODE = '%s (Arguments: %s) returns error code %s';

  LNG_FILE_NOT_FOUND = 'File not found: %s';

  LNG_INVALID_INFO_FORMAT = 'Unexpected record size: %s';

  LNG_DRIVE_NOT_EXISTING = 'Drive %s does not exist.';

 

  C_SHQueryRecycleBin = 'SHQueryRecycleBinA';

  C_GetVolumeNameForVolumeMountPoint = 'GetVolumeNameForVolumeMountPointA';

  C_SHEmptyRecycleBinA = 'SHEmptyRecycleBinA';

  C_SHGetSettings = 'SHGetSettings';

  C_SHGetSetSettings = 'SHGetSetSettings';

 

  TSHQueryRecycleBin = function(pszRootPath: LPCTSTR; var pSHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall;

  TGetVolumeNameForVolumeMountPointA = function(lpszVolumeMountPoint: LPCSTR; lpszVolumeName: LPSTR; cchBufferLength: DWORD): BOOL; stdcall;

  TSHEmptyRecycleBin = function(Wnd: HWND; pszRootPath: PChar; dwFlags: DWORD): HRESULT; stdcall;

  TSHGetSettings = procedure(var lpss: SHELLSTATE; dwMask: DWORD); stdcall;

  TSHGetSetSettings = procedure(var lpss: SHELLSTATE; dwMask: DWORD; bSet: BOOL); stdcall;

 

function WideCharArrayToWideString(x: array of WideChar): WideString;

  i: integer;

  // In x86, the "cast" works with WideString.

  // In x64, it does not work (outputs empty string, without compiler warning!)

  // So, we created this fake-cast

  SetLength(result, Length(x));

  for i := 0 to Length(x)-1 do

    result[i+1] := x[i];

 

function AnsiCharArrayToWideString(x: array of AnsiChar): WideString;

  i: integer;

  SetLength(result, Length(x));

  for i := 0 to Length(x)-1 do

    result[i+1] := WideChar(x[i]);

 

procedure AnsiRemoveNulChars(var s: AnsiString);

  while (Length(s) > 0) and (s[Length(s)] = #0) do

    s := Copy(s, 1, Length(s)-1);

 

procedure UnicodeRemoveNulChars(var s: WideString);

  while (Length(s) > 0) and (s[Length(s)] = #0) do

    s := Copy(s, 1, Length(s)-1);

 

function GetDriveGUID(driveLetter: AnsiChar; var guid: TGUID): DWORD;

  Buffer: array[0..50] of AnsiChar;

  x: string;

  PGetVolumeNameForVolumeMountPointA: TGetVolumeNameForVolumeMountPointA;

  RBHandle: THandle;

  RBHandle := LoadLibrary(kernel32);

  try

    if RBHandle <> 0 then

    begin

      PGetVolumeNameForVolumeMountPointA := GetProcAddress(RBHandle, C_GetVolumeNameForVolumeMountPoint);

      if not Assigned(@PGetVolumeNameForVolumeMountPointA) then

      begin

        result := GetLastError;

        FreeLibrary(RBHandle);

        RBHandle := 0;

      end

      else

      begin

        if PGetVolumeNameForVolumeMountPointA(PAnsiChar(AnsiString(driveLetter+':\')), Buffer, SizeOf(Buffer)) then

        begin

          x := string(buffer);

          x := copy(x, 11, 38);

          guid := StringToGUID(x);

          result := ERROR_SUCCESS;

        end

        else

          result := GetLastError;

      end;

    end

    else result := GetLastError;

  finally

    if RBHandle <> 0 then FreeLibrary(RBHandle);

  end;

 

function FileTimeToDateTime(FileTime: FILETIME): TDateTime;

  SystemTime: TSystemTime;

  nowUTC: TDateTime;

  gmtDifference: int64;

  GetSystemTime(SystemTime);

  with SystemTime do

  begin

    // http://www.delphipraxis.net/post340194.html#34019

    nowUTC := EncodeDate(wYear, wMonth, wDay) +

              EncodeTime(wHour, wMinute, wSecond, wMilliseconds);

  end;

 

  gmtDifference := datetimetounix(nowUTC) - datetimetounix(Now);

 

  // http://www.e-fense.com/helix/Docs/Recycler_Bin_Record_Reconstruction.pdf states:

  // UnixTime = 0.0000001 * NTTime + 11644473600

  // This is wrong! The correct formula is:

  // UnixTime = 0.0000001 * NTTime - 11644473600 + c * 3600

  // c = GMT-Difference (MEZ = 1) inclusive daylight saving time (+3600 seconds)

  result := unixtodatetime(round(0.0000001 * int64(FileTime)) - 11644473600 - gmtDifference);

  LocalTime: TFileTime;

  DOSTime: Integer;

  FileTimeToLocalFileTime(FileTime, LocalTime);

  FileTimeToDosDateTime(LocalTime, LongRec(DOSTime).Hi, LongRec(DOSTime).Lo);

  Result := FileDateToDateTime(DOSTime);

 

function DeleteDirectory(const Name: string): boolean;

  F: TSearchRec;

  result := true;

  if FindFirst(IncludeTrailingPathDelimiter(Name) + '*', faAnyFile, F) = 0 then

  begin

    try

      repeat

        if F.Attr and faDirectory <> 0 then

        begin

          if (F.Name <> '.') and (F.Name <> '..') then

          begin

            result := result and DeleteDirectory(IncludeTrailingPathDelimiter(Name) + F.Name);

          end;

        end

        else

        begin

          if not DeleteFile(IncludeTrailingPathDelimiter(Name) + F.Name) then result := false;

        end;

      until FindNext(F) <> 0;

    finally

      FindClose(F);

    end;

    if not RemoveDir(Name) then result := false;

  end;

 

function DriveLetterToDriveNumber(driveLetter: AnsiChar): integer;

  tmp: string;

  tmp := LowerCase(string(driveLetter));

  result := Ord(tmp[1])-Ord('a');

 

function GetStringFromDLL(filename: string; num: integer): string;

  // Source: http://www.eggheadcafe.com/forumarchives/vcmfc/sep2005/post23917443.asp

  MAX_BUF = 4097; // OK?

  hLib: THandle;

  buf: array[0..MAX_BUF] of char;

  hLib := LoadLibrary(PChar(filename));

  try

    LoadString(hLib, num, buf, sizeof(buf));

    result := buf;

  finally

    FreeLibrary(hLib);

  end;

 

function ExpandEnvStr(const szInput: string): string;

  MAXSIZE = 32768; // laut PSDK sind 32k das Maximum

  // Source: http://www.delphi-library.de/topic_Umgebungsvariable+in+einem+String+aufloesen_20516,0.html

  SetLength(Result,MAXSIZE);

  SetLength(Result,ExpandEnvironmentStrings(pchar(szInput),

    @Result[1],length(Result))-1); //-1 um abschließendes #0 zu verwerfen

 

function DecodeReferenceString(s: string): string;

  dll, id, lang, cache: string;

  sl, sl2: tstringlist;

  // Beispiele

  // Papierkorb                                                 -- Windows 95

  // @C:\WINNT\system32\shell32.dll,-8964@1031,Papierkorb       -- Windows 2000

 

  if Copy(s, 1, 1) = '@' then

  begin

    // Referenz auf eine DLL

    // @<dll>,-<id>[@<lang>][,<cache>]

 

    sl := TStringList.Create;

    try

      // '@' am Anfang entfernen

      s := Copy(s, 2, length(s)-1);

 

      // Nach ',' auftrennen

      // sl[0] --> dll

      // sl[1] --> -id@lang

      // sl[2] --> cache

      sl.CommaText := s;

 

      if sl.Count > 2 then

      begin

        // Das Ergebnis ist bereits im Klartext vorhanden und muss nicht extrahiert werden

        // Ist bei Windows 2000 der Fall

        cache := sl[2];

        result := cache;

        exit;

      end;

 

      if sl.Count > 1 then

      begin

        dll := sl[0];

 

        sl2 := TStringList.Create;

        try

          // Nach '@' auftrennen

          // sl2[0] --> id

          // sl2[1] --> lang

          sl2.CommaText := StringReplace(sl[1], '@', ',', [rfReplaceAll]);

 

          id := sl2[0];

 

          if sl2.Count > 1 then

          begin

            // ToDo: In Zukunft beachten, sofern möglich

            lang := sl2[1];

          end;

 

          // Umgebungsvariablen erkennen und Minuszeichen entfernen

          result := GetStringFromDLL(ExpandEnvStr(dll), -StrToInt(id));

        finally

          sl2.Free;

        end;

      end

      else

      begin

        // Zu wenige Informationen!

 

        result := '';

      end;

    finally

      sl.Free;

    end;

  end

  else

  begin

    // Kein Hinweis auf eine Referenz

    result := s;

  end;

 

function GPBoolToString(value: GPOLICYBOOL): string;

  case value of

    gpUndefined: result := 'Not configured';

    gpEnabled: result := 'Enabled';

    gpDisabled: result := 'Disabled';

  end;

 

 

constructor TRbRecycleBin.Create(AFileOrDirectory: string; ASID: string='');

  inherited Create;

 

  FFileOrDirectory := AFileOrDirectory;

  FSID := ASID;

  TolerantReading := true;

 

function TRbRecycleBin.CheckIndexes(slErrors: TStrings): boolean;

 

  procedure _Assert(assertion: boolean; msg: string; args: array of const);

  begin

    if not assertion then

    begin

      slErrors.Add(Format(msg, args));

      result := false;

    end;

  end;

 

  procedure _HandleIndexFile(AFile: string);

  var

    fs: TFileStream;

    infoHdr: TRbInfoHeader;

  resourcestring

    LNG_IDXERR_VISTA_FILESIZE = '%s: Vista index file has wrong size';

    LNG_IDXERR_INFO_RECSIZE_UNEXPECTED = '%s: record size unexpected';

    LNG_IDXERR_INFO_UNEXPECTED_EOF = '%s: file size wrong';

  begin

    fs := TFileStream.Create(AFile, fmOpenRead);

    try

      fs.Seek(0, soFromBeginning);

 

      if SameText(copy(ExtractFileName(AFile), 1, 2), '$I') then

      begin

        _Assert(fs.Size = SizeOf(TRbVistaItem), LNG_IDXERR_VISTA_FILESIZE, [AFile]);

      end

      else if SameText(ExtractFileName(AFile), 'INFO') or

              SameText(ExtractFileName(AFile), 'INFO2') then

      begin

        fs.ReadBuffer(infoHdr, SizeOf(infoHdr));

        _Assert((infoHdr.recordLength = SizeOf(TRbInfoRecordA)) or

                (infoHdr.recordLength = SizeOf(TRbInfoRecordW)), LNG_IDXERR_INFO_RECSIZE_UNEXPECTED, [AFile]);

        _Assert((fs.Size-fs.Position) mod infoHdr.recordLength = 0, LNG_IDXERR_INFO_UNEXPECTED_EOF, [AFile]);

        // TODO: we can also check infoHdr.totalSize or infoHdr.totalEntries

      end

      else Assert(false);

 

      // TODO: we could check each item for invalid stuff...?

    finally

      FreeAndNil(fs);

    end;

  end;

 

  procedure _HandleVistaDir(ADirectory: string);

  var

    SR: TSearchRec;

  begin

    ADirectory := IncludeTrailingPathDelimiter(ADirectory);

 

    if FindFirst(ADirectory + '$I*', faAnyFile, SR) = 0 then

    begin

      repeat

        _HandleIndexFile(ADirectory+sr.Name);

      until FindNext(SR) <> 0;

    end;

    FindClose(SR);

  end;

 

  result := true;

 

  if DirectoryExists(FFileOrDirectory) then // Vista, as well as directories with INFO and INFO2

  begin

    _HandleVistaDir(FFileOrDirectory);

 

    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2') then

    begin

      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2');

    end;

 

    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO') then

    begin

      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO');

    end;

  end

  else if FileExists(FFileOrDirectory) then

  begin

    _HandleIndexFile(FFileOrDirectory);

  end

  else raise Exception.CreateFmt(LNG_FILE_NOT_FOUND, [FFileOrDirectory]);

 

function TRbRecycleBin.GetItem(id: string): TRbRecycleBinItem;

 

  procedure _HandleIndexFile(AFile: string);

  var

    fs: TFileStream;

    infoHdr: TRbInfoHeader;

    testItem: TRbRecycleBinItem;

  begin

    fs := TFileStream.Create(AFile, fmOpenRead);

    try

      fs.Seek(0, soFromBeginning);

 

      if SameText(ExtractFileName(AFile), '$I'+id) then

      begin

        result := TRbVistaItem.Create(fs, AFile, id);

      end

      else

      begin

        fs.ReadBuffer(infoHdr, SizeOf(infoHdr));

        case infoHdr.recordLength of

          SizeOf(TRbInfoRecordA):

          begin

            while fs.Position < fs.size do

            begin

              testItem := TRbInfoAItem.Create(fs, AFile);

              if testItem.ID = id then

              begin

                result := testItem;

                break;

              end;

            end;

          end;

          SizeOf(TRbInfoRecordW):

          begin

            while fs.Position < fs.size do

            begin

              testItem := TRbInfoWItem.Create(fs, AFile);

              if testItem.ID = id then

              begin

                result := testItem;

                break;

              end;

            end;

          end

          else

          begin

            raise Exception.CreateFmt(LNG_INVALID_INFO_FORMAT, [AFile]);

          end;

        end;

      end;

    finally

      FreeAndNil(fs);

    end;

  end;

 

  procedure _HandleVistaDir(ADirectory: string);

  var

    SR: TSearchRec;

    fs: TFileStream;

    id: string;

  begin

    ADirectory := IncludeTrailingPathDelimiter(ADirectory);

 

    if FileExists(ADirectory + '$I' + id) then

    begin

      fs := TFileStream.Create(ADirectory+sr.Name, fmOpenRead);

      try

        fs.Seek(0, soFromBeginning);

        result := TRbVistaItem.Create(fs, ADirectory+sr.Name, id);

      finally

        FreeAndNil(fs);

      end;

    end;

  end;

 

  result := nil;

 

  if DirectoryExists(FFileOrDirectory) then // Vista, as well as directories with INFO and INFO2

  begin

    _HandleVistaDir(FFileOrDirectory);

    if Assigned(result) then exit;

 

    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2') then

    begin

      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2');

      if Assigned(result) then exit;

    end;

 

    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO') then

    begin

      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO');

      if Assigned(result) then exit;

    end;

  end

  else if FileExists(FFileOrDirectory) then

  begin

    _HandleIndexFile(FFileOrDirectory);

    if Assigned(result) then exit;

  end

  else raise Exception.CreateFmt(LNG_FILE_NOT_FOUND, [FFileOrDirectory]);

 

procedure TRbRecycleBin.ListItems(list: TObjectList{TRbRecycleBinItem});

 

  procedure _HandleIndexFile(AFile: string);

  var

    fs: TFileStream;

    infoHdr: TRbInfoHeader;

    testID: string;

    wTest: TRbInfoWItem;

    bakPosition: int64;

  begin

    fs := TFileStream.Create(AFile, fmOpenRead);

    try

      fs.Seek(0, soFromBeginning);

 

      if SameText(copy(ExtractFileName(AFile), 1, 2), '$I') then

      begin

        testID := copy(testID, 3, Length(testID)-2);

        list.Add(TRbVistaItem.Create(fs, AFile, testID));

      end

      else

      begin

        if TolerantReading then

        begin

          // This is a special treatment how to recover data from an INFO/INFO2 file

          // which was corrupted by an incompatible multiboot configuration.

          // Example:

          // - Win95 without IE4 and WinNT4 both write into the INFO file. But Win95 appends the ANSI record and WinNT appends an Unicode record.

          // - Win95 with IE4 and Windows 2000/2003/XP write into the INFO2 file. But Win9x appends the ANSI record and Win2k+ appends an Unicode record.

          fs.ReadBuffer(infoHdr, SizeOf(infoHdr));

          while fs.Position < fs.size do

          begin

            // Can we actually read a Unicode record?

            if fs.Position + SizeOf(TRbInfoRecordW) <= fs.Size then

            begin

              // Try to read the Unicode record and check if it is valid

              // In case it is no Unicode record, then the Unicode part will be the

              // ANSI source name of the next record. In this case, we won't get

              // a ':' at the Unicode string.

              bakPosition := fs.Position;

              wTest := TRbInfoWItem.Create(fs, AFile);

              if Copy(wTest.SourceUnicode, 2, 1) = ':' then

              begin

                // Yes, it is a valid Unicode record.

                list.Add(wTest);

              end

              else

              begin

                // No, it is not a valid Unicode record. Jump back, and we need

                // to assume that the following record will be a valid ANSI record.

                fs.Position := bakPosition;

                list.Add(TRbInfoAItem.Create(fs, AFile));

              end;

            end

            else

            begin

              // No, there is not enough space left for an Unicode record.

              // So we assume that the following record will be a valid ANSI record.

              list.Add(TRbInfoAItem.Create(fs, AFile));

            end;

          end;

        end

        else

        begin

          // This is the code for non-tolerant reading of the records.

          fs.ReadBuffer(infoHdr, SizeOf(infoHdr));

          case infoHdr.recordLength of

            SizeOf(TRbInfoRecordA):

            begin

              while fs.Position < fs.size do

              begin

                list.Add(TRbInfoAItem.Create(fs, AFile));

              end;

            end;

            SizeOf(TRbInfoRecordW):

            begin

              while fs.Position < fs.size do

              begin

                list.Add(TRbInfoWItem.Create(fs, AFile));

              end;

            end

            else

            begin

              raise Exception.CreateFmt(LNG_INVALID_INFO_FORMAT, [AFile]);

            end;

          end;

        end;

      end;

    finally

      FreeAndNil(fs);

    end;

  end;

 

  procedure _HandleVistaDir(ADirectory: string);

  var

    SR: TSearchRec;

    fs: TFileStream;

    id: string;

  begin

    ADirectory := IncludeTrailingPathDelimiter(ADirectory);

 

    if FindFirst(ADirectory + '$I*', faAnyFile, SR) = 0 then

    begin

      repeat

        id := sr.Name;

        { id := ChangeFileExt(id, ''); }  // Removed code: We keep the file extention as part of the ID, because we do not know if the ID is otherwise unique

        id := Copy(id, 3, Length(id)-2);

 

        fs := TFileStream.Create(ADirectory+sr.Name, fmOpenRead);

        try

          fs.Seek(0, soFromBeginning);

          list.Add(TRbVistaItem.Create(fs, ADirectory+sr.Name, id));

        finally

          FreeAndNil(fs);

        end;

      until FindNext(SR) <> 0;

    end;

    FindClose(SR);

  end;

 

  if DirectoryExists(FFileOrDirectory) then // Vista, as well as directories with INFO and INFO2

  begin

    _HandleVistaDir(FFileOrDirectory);

 

    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2') then

    begin

      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2');

    end;

 

    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO') then

    begin

      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO');

    end;

  end

  else if FileExists(FFileOrDirectory) then

  begin

    _HandleIndexFile(FFileOrDirectory); // Either INFO, or INFO2, or a single Vista index file

  end

  else raise Exception.CreateFmt(LNG_FILE_NOT_FOUND, [FFileOrDirectory]);

 

 

procedure TRbDrive.CheckDriveExisting;

  // Does the drive exist?

  // see http://www.delphipraxis.net/post2933.html

  if not GetLogicalDrives and (1 shl DriveNumber) <> 0 then

  begin

    raise EInvalidDrive.CreateFmt(LNG_DRIVE_NOT_EXISTING, [UpperCase(string(FDriveLetter))+':']);

  end;

 

constructor TRbDrive.Create(ADriveLetter: AnsiChar);

  inherited Create;

 

  FDriveLetter := ADriveLetter;

  CheckDriveExisting;

 

function TRbDrive.DiskSize: integer;

  result := SysUtils.DiskSize(DriveNumber+1 {0 is current, 1 is A}) div (1024*1024);

 

function TRbDrive.DriveNumber: integer;

  result := DriveLetterToDriveNumber(FDriveLetter);

 

function TRbDrive.GetAPIInfo: TSHQueryRBInfo;

  PSHQueryRecycleBin: TSHQueryRecycleBin;

  RBHandle: THandle;

  res: HRESULT;

  Path: string;

  Path := FDriveLetter + ':\';

 

  // Ref: http://www.delphipraxis.net/post1291.html

 

  RBHandle := LoadLibrary(shell32);

  try

    PSHQueryRecycleBin := nil;

    if RBHandle <> 0 then

    begin

      PSHQueryRecycleBin := GetProcAddress(RBHandle, C_SHQueryRecycleBin);

      if not Assigned(@PSHQueryRecycleBin) then

      begin

        FreeLibrary(RBHandle);

        RBHandle := 0;

      end;

    end;

 

    FillChar(result, SizeOf(TSHQueryRBInfo), 0);

    result.cbSize := SizeOf(TSHQueryRBInfo);

 

    if (RBHandle <> 0) and Assigned(PSHQueryRecycleBin) then

    begin

      res := PSHQueryRecycleBin(PChar(Path), result);

      // if Succeeded(res) then

      if res = S_OK then

      begin

        // Alles OK, unser result hat nun die gewünschten Daten.

      end

      else

      begin

        // Since Windows Vista, SHQueryRecycleBin will fail with E_FAIL (80004005)

        // if Path is a floppy or CD drive...

        raise EAPICallError.CreateFmt(LNG_API_CALL_ERROR, [Format(LNG_ERROR_CODE, [C_SHQueryRecycleBin, Path, '0x'+IntToHex(res, 2*SizeOf(HRESULT))])]);

      end;

    end

    else

      raise EAPICallError.CreateFmt(LNG_API_CALL_ERROR, [Format(LNG_NOT_CALLABLE, [C_SHQueryRecycleBin])]);

  finally

    if RBHandle <> 0 then FreeLibrary(RBHandle);

  end;

 

function TRbDrive.GetMaxPercentUsage: Extended;

  abs: integer; // in MB

  rel: integer; // in % (0-100)

  gpSetting: integer;

  DEFAULT_PERCENT = 10; // Windows 95 default

  gpSetting := TRecycleBinManager.RecyclerGroupPolicyRecycleBinSize;

  if gpSetting <> -1 then

    result := gpSetting / 100

  else if TRecycleBinManager.UsesGlobalSettings then

    result := TRecycleBinManager.GetGlobalMaxPercentUsage / 100

  else if OldCapacityPercent(rel) then

  begin

    result := rel / 100;

  end

  else if NewCapacityAbsolute(abs) then

  begin

    result := abs / DiskSize;

  end

  else

  begin

    result := DEFAULT_PERCENT / 100;

  end;

 

function TRbDrive.GetMaxAbsoluteUsage: integer;

  abs: integer; // in MB

  rel: integer; // in % (0-100)

  gpSetting: integer;

  DEFAULT_PERCENT = 10; // Windows 95 default

  gpSetting := TRecycleBinManager.RecyclerGroupPolicyRecycleBinSize;

  if gpSetting <> -1 then

    result := Ceil(gpSetting/100 * DiskSize)

  else if TRecycleBinManager.UsesGlobalSettings then

    result := Ceil(TRecycleBinManager.GetGlobalMaxPercentUsage/100 * DiskSize)

  else if NewCapacityAbsolute(abs) then

  begin

    result := abs;

  end

  else if OldCapacityPercent(rel) then

  begin

    result := Ceil(rel/100 * DiskSize);

  end

  else

  begin

    result := Ceil(DEFAULT_PERCENT/100 * DiskSize);

  end;

 

function TRbDrive.OldCapacityPercent(var res: integer): boolean;

  reg: TRegistry;

  purgeInfo: TRbWin95PurgeInfo;

  if Win32MajorVersion >= 6 then

  begin

    // Only available till Windows XP

    result := false;

    exit;

  end;

 

  result := false;

 

  reg := TRegistry.Create;

  try

    reg.RootKey := HKEY_LOCAL_MACHINE;

 

    // Im Auslieferungszustand von Windows 95 ist dieser Schlüssel nicht vorhanden.

    // Er wird bei der ersten Änderung der Papierkorb-Einstellungen erstellt.

    if reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\BitBucket') then

    begin

      if reg.OpenKeyReadOnly(string(FDriveLetter)) then

      begin

        if reg.ValueExists('Percent') then

        begin

          // Windows 2000 - Informationen liegen aufgeschlüsselt in der Registry

 

          res := reg.ReadInteger('Percent');

          result := true;

        end;

      end

      else

      begin

        if reg.ValueExists('PurgeInfo') then

        begin

          // Windows 95 - Kodierte Informationen liegen in PurgeInfo

 

          reg.ReadBinaryData('PurgeInfo', purgeInfo, SizeOf(purgeInfo));

 

          res := purgeInfo.percentDrive[FDriveLetter];

          result := true;

        end;

      end;

 

      reg.CloseKey;

    end;

  finally

    reg.Free;

  end;

 

function TRbDrive.NewCapacityAbsolute(var res: integer): boolean;

  reg: TRegistry;

  if Win32MajorVersion < 6 then

  begin

    // Only available since Windows Vista

    result := false;

    exit;

  end;

 

  result := false;

 

  reg := TRegistry.Create;

  try

    reg.RootKey := HKEY_CURRENT_USER;

 

    if reg.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Explorer\BitBucket\Volume') then

    begin

      // Windows Vista and upwards

      if reg.OpenKeyReadOnly(GUIDToString(VolumeGUID)) then

      begin

        res := reg.ReadInteger('MaxCapacity'); // in MB

        result := true;

      end;

      reg.CloseKey;

    end;

  finally

    reg.Free;

  end;

 

function TRbDrive.GetNukeOnDelete: boolean;

  reg: TRegistry;

  purgeInfo: TRbWin95PurgeInfo;

  RES_DEFAULT = false; // Windows 95 default

  if TRecycleBinManager.RecyclerGroupPolicyNoRecycleFiles = gpEnabled then

    result := true

  else if TRecycleBinManager.UsesGlobalSettings then

    result := TRecycleBinManager.GetGlobalNukeOnDelete

  else

  begin

    result := RES_DEFAULT;

 

    reg := TRegistry.Create;

    try

      reg.RootKey := HKEY_CURRENT_USER;

 

      if reg.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Explorer\BitBucket\Volume') then

      begin

        // Windows Vista and upwards

        if reg.OpenKeyReadOnly(GUIDToString(VolumeGUID)) then

        begin

          result := reg.ReadBool('NukeOnDelete');

        end;

        reg.CloseKey;

      end

      else

      begin

        reg.RootKey := HKEY_LOCAL_MACHINE;

 

        // Im Auslieferungszustand von Windows 95 ist dieser Schlüssel nicht vorhanden.

        // Er wird bei der ersten Änderung der Papierkorb-Einstellungen erstellt.

        if reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\BitBucket') then

        begin

          if reg.OpenKeyReadOnly(string(FDriveLetter)) then

          begin

            if reg.ValueExists('NukeOnDelete') then

            begin

              // Windows 2000 - Informationen liegen aufgeschlüsselt in der Registry

 

              result := reg.ReadBool('NukeOnDelete');

            end;

          end

          else

          begin

            if reg.ValueExists('PurgeInfo') then

            begin

              // Windows 95 - Kodierte Informationen liegen in PurgeInfo

 

              reg.ReadBinaryData('PurgeInfo', purgeInfo, SizeOf(purgeInfo));

 

              result := ((purgeInfo.NukeOnDeleteBits shr DriveNumber) and 1) = 1;

            end;

          end;

 

          reg.CloseKey;

        end;

      end;

    finally

      reg.Free;

    end;

  end;

 

function TRbDrive.GetNumItems: int64;

  result := GetAPIInfo.i64NumItems;

 

function TRbDrive.GetSize: int64;

  result := GetAPIInfo.i64Size;

 

function TRbDrive.GetVolumeGUID: TGUID;

  if GetDriveGUID(FDriveLetter, result) <> ERROR_SUCCESS then

  begin

    result := NULL_GUID;

  end;

 

function TRbDrive.GetVolumeGUIDAvailable: boolean;

  result := not IsEqualGUID(VolumeGUID, NULL_GUID);

 

function TRbDrive.IsEmpty: boolean;

  result := GetNumItems = 0;

 

function TRbDrive.IsFAT: boolean;

  Dummy2: DWORD;

  Dummy3: DWORD;

  FileSystem: array[0..MAX_PATH] of char;

  VolumeName: array[0..MAX_PATH] of char;

  s: string;

  s := FDriveLetter + DriveDelim + PathDelim; // ohne die Auslagerung in einen String kommt es zu einer AV in ntdll

  GetVolumeInformation(PChar(s), VolumeName,

    SizeOf(VolumeName), nil, Dummy2, Dummy3, FileSystem, SizeOf(FileSystem));

  result := uppercase(copy(FileSystem, 0, 3)) = 'FAT';

 

procedure TRbDrive.ListRecycleBins(list: TObjectList{TRbRecycleBin}; UserSID: string='');

 

  procedure _AddSIDFolders(dir: string; wholeFolder: boolean);

  var

    SR: TSearchRec;

  begin

    dir := IncludeTrailingPathDelimiter(dir);

    if FindFirst(dir+'S-*', faAnyFile, SR) = 0 then

    begin

      try

        repeat

          if (SR.Name = '.') or (SR.Name = '..') or not DirectoryExists(dir + SR.Name) then continue;

 

          if wholeFolder then

          begin

            // Vista

            list.Add(TRbRecycleBin.Create(dir+SR.Name, SR.Name));

          end

          else

          begin

            // Win95 .. WinXP

            if FileExists(IncludeTrailingPathDelimiter(dir+SR.Name) + 'INFO2') then

              list.Add(TRbRecycleBin.Create(IncludeTrailingPathDelimiter(dir+SR.Name) + 'INFO2', SR.Name));

            if FileExists(IncludeTrailingPathDelimiter(dir+SR.Name) + 'INFO') then

              list.Add(TRbRecycleBin.Create(IncludeTrailingPathDelimiter(dir+SR.Name) + 'INFO', SR.Name));

          end;

        until FindNext(SR) <> 0;

      finally

        FindClose(SR);

      end;

    end;

  end;

 

  dir: string;

  // Find recyclers from Windows Vista or higher

 

  if IsFAT then

  begin

    dir := FDriveLetter + DriveDelim + PathDelim + '$recycle.bin' + PathDelim;

    if DirectoryExists(dir) then

    begin

      list.Add(TRbRecycleBin.Create(dir));

    end;

  end

  else

  begin

    if UserSID <> '' then

    begin

      dir := FDriveLetter + DriveDelim + PathDelim + '$recycle.bin' + PathDelim + UserSID + PathDelim;

      if DirectoryExists(dir) then

      begin

        list.Add(TRbRecycleBin.Create(dir, UserSID));

      end;

    end

    else

    begin

      _AddSIDFolders(FDriveLetter + DriveDelim + PathDelim + '$recycle.bin', true);

    end;

  end;

 

  // Find recyclers from Windows before Vista

 

  if IsFAT then

  begin

    dir := FDriveLetter + DriveDelim + PathDelim + 'Recycled' + PathDelim;

 

    // Both "recycle bins" are possible if you have multiboot (but do overwrite themselfes if you empty them)

    if FileExists(dir + 'INFO2') then

      list.Add(TRbRecycleBin.Create(dir + 'INFO2')); // Windows 95 with Internet Explorer 4 Extension or higher Windows 9x versions

    if FileExists(dir + 'INFO') then

      list.Add(TRbRecycleBin.Create(dir + 'INFO')); // Windows 95 native

  end

  else

  begin

    if UserSID <> '' then

    begin

      dir := FDriveLetter + DriveDelim + PathDelim + 'Recycler' + PathDelim + UserSID + PathDelim;

 

      if FileExists(dir + 'INFO2') then

        list.Add(TRbRecycleBin.Create(dir + 'INFO2', UserSID)); // Windows 2000+

      if FileExists(dir + 'INFO') then

        list.Add(TRbRecycleBin.Create(dir + 'INFO', UserSID)); // Windows NT 4

    end

    else

    begin

      _AddSIDFolders(FDriveLetter + DriveDelim + PathDelim + 'Recycler', false);

    end;

  end;

 

 

procedure TRbInfoAItem.ReadFromStream(stream: TStream);

  r: TRbInfoRecordA;

  stream.ReadBuffer(r, SizeOf(r));

 

  FSourceDrive := Chr(Ord('A') + r.sourceDrive);

 

  // Win95 with IE4 and Win2000+:

  // Wenn ein Eintrag aus der INFO/INFO2 gelöscht wird, dann wird das erste Byte

  // von sourceAnsi auf Null gesetzt, damit die ganze INFO/INFO2 Datei nicht

  // ständig neu geschrieben werden muss (so wie es bei Win95 und WinNT4 der Fall war).

  // Wir lesen den Eintrag trotzdem, da unsere Software ja auch zu forensischen

  // Zwecken eingesetzt werden soll.

  if r.sourceAnsi[0] = #0 then

  begin

    FRemovedEntry := true;

    r.sourceAnsi[0] := AnsiChar(FSourceDrive);

  end;

 

  FSourceAnsi := r.sourceAnsi;

  FSourceUnicode := AnsiCharArrayToWideString(r.sourceAnsi); // Unicode does not exist in INFO(1) structure

  FID := IntToStr(r.recordNumber);

  FDeletionTime := FileTimeToDateTime(r.deletionTime);

  FOriginalSize := r.originalSize;

 

  // Remove #0 at the end. There are some bugs where #0 is added to ANSI/Unicode read paths?! (probably in the ReadVista stuff)

  // TODO: Instead of using this workaround, fix "SourceUnicode" and "SourceAnsi" in the first place!

  AnsiRemoveNulChars(FSourceAnsi);

  UnicodeRemoveNulChars(FSourceUnicode);

 

function TRbInfoAItem.DeleteFile: boolean;

  r: string;

  r := GetPhysicalFile;

  if DirectoryExists(r) then

    result := DeleteDirectory(r) // Usually, the old recycle bin does not allow folders. Just to be sure, we include the code.

  else

    result := SysUtils.DeleteFile(r); // TODO: geht das oder gibt es zugriffsverletzung? --> Win95: Funktioniert

 

  // TODO: nun auch den eintrag aus der INFO-Datei rausschmeißen (Datei neu schreiben)

 

function TRbInfoAItem.GetPhysicalFile: string;

  if FRemovedEntry then

  begin

    result := '';

    Exit;

  end;

 

  // e.g. C:\...\DC0.doc

  result := IncludeTrailingPathDelimiter(ExtractFilePath(IndexFile)) +

            'D' + (* SourceDrive *) Source[1] + ID + ExtractFileExt(Source);

 

constructor TRbInfoAItem.Create(fs: TStream; AIndexFile: string);

  inherited Create;

  ReadFromStream(fs);

  FIndexFile := AIndexFile;

 

 

procedure TRbInfoWItem.ReadFromStream(stream: TStream);

  r: TRbInfoRecordW;

  stream.ReadBuffer(r, SizeOf(r));

 

  // Win95 with IE4 and Win2000+:

  // Wenn ein Eintrag aus der INFO/INFO2 gelöscht wird, dann wird das erste Byte

  // von sourceAnsi auf Null gesetzt, damit die ganze INFO/INFO2 Datei nicht

  // ständig neu geschrieben werden muss (so wie es bei Win95 und WinNT4 der Fall war).

  // Wir lesen den Eintrag trotzdem, da unsere Software ja auch zu forensischen

  // Zwecken eingesetzt werden soll.

  if r.sourceAnsi[0] = #0 then

  begin

    FRemovedEntry := true;

    r.sourceAnsi[0] := AnsiChar(r.sourceUnicode[0]);

  end;

 

  FSourceAnsi := r.sourceAnsi;

  FSourceUnicode := r.sourceUnicode;

  FID := IntToStr(r.recordNumber);

  FSourceDrive := Chr(Ord('A') + r.sourceDrive);

  FDeletionTime := FileTimeToDateTime(r.deletionTime);

  FOriginalSize := r.originalSize;

 

  // Remove #0 at the end. There are some bugs where #0 is added to ANSI/Unicode read paths?! (probably in the ReadVista stuff)

  // TODO: Instead of using this workaround, fix "SourceUnicode" and "SourceAnsi" in the first place!

  AnsiRemoveNulChars(FSourceAnsi);

  UnicodeRemoveNulChars(FSourceUnicode);

 

function TRbInfoWItem.DeleteFile: boolean;

  r: string;

  r := GetPhysicalFile;

  if DirectoryExists(r) then

    result := DeleteDirectory(r)

  else