Subversion Repositories recyclebinunit

Rev

Rev 75 | Rev 77 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
75 daniel-mar 1
unit RecBinUnit2 platform;
2
 
3
////////////////////////////////////////////////////////////////////////////////////
76 daniel-mar 4
// RECYCLE-BIN-UNIT V2 BY DANIEL MARSCHALL, VIATHINKSOFT                          //
75 daniel-mar 5
// E-MAIL: info@daniel-marschall.de                                               //
76 daniel-mar 6
// Web:    www.daniel-marschall.de & www.viathinksoft.de                          //
75 daniel-mar 7
////////////////////////////////////////////////////////////////////////////////////
76 daniel-mar 8
// Revision: 03 JUL 2016                                                          //
75 daniel-mar 9
// This unit is freeware, but please link to my website if you are using it!      //
10
////////////////////////////////////////////////////////////////////////////////////
11
// Successfully tested with:                                                      //
12
// Windows 95b (without IE4 Shell Extensions)                                     //
13
// Windows 95b (with IE4 Shell Extensions)                                        //
76 daniel-mar 14
// Windows 98 SE                                                                  //
75 daniel-mar 15
// Windows NT4 SP6                                                                //
76 daniel-mar 16
// Windows XP SP3                                                                 //
17
// Windows 2000 SP4                                                               //
75 daniel-mar 18
// Windows 2003 Server EE SP1                                                     //
19
// Windows Vista                                                                  //
20
// Windows 7                                                                      //
21
// Windows 10                                                                     //
22
////////////////////////////////////////////////////////////////////////////////////
23
 
24
// Delphi 7 Compatibility:  (TODO: compiler switches)
25
// - Remove "static"
26
// - Remove "strict"
27
// - Remove "$REGION"
28
 
29
// TODO: ReadBuffer überall try-except
30
// TODO: Win7 : Drive GUIDs
31
// TODO: Win7 : Absolute vs. Relative size limitations
32
// TODO: Always check EOF before reading anything?
76 daniel-mar 33
// TODO: Don't crash when timestamp is invalid. Do something else instead.
75 daniel-mar 34
// TODO: Is it possible to identify a Vista-file that is not named $Ixxxxxx.ext?
35
// TODO: RecyclerGetInfofiles() check additionally for removable device?
36
//       RecyclerIsValid() is false.
37
// TODO: Make it possible to empty the recycle bin of one specific drive!
38
// TODO: Unknown! Do you know the answer?
39
//       - How does Windows 9x/NT manage the daylight saving time (if it does)?
40
//       - How does Windows Vista+ react to a RECYCLER\ folder on a NTFS device?
41
//       - How does Windows Vista+ react to a RECYCLED\ folder on a FAT device? ==> Win7: is ignored!
42
//       - How does Windows XP react to RECYCLED\ folder on a FAT device?
43
// TODO: Translate all comments from German to English
44
// TODO: do we need this (maybe not all drives have A: till Z:?) http://stackoverflow.com/questions/17110543/how-to-retrieve-the-disk-signature-of-all-the-disks-in-windows-using-delphi-7
45
 
46
// If enabled, the deletion timestamps will not be converted by the WinAPI.
47
{.$DEFINE FILETIME_DELPHI_CODE}
48
 
49
// If a value is set in HKEY_LOCAL_MACHINE, it will be prefered, even if gpedit.msc shows "Not configured"!
50
{$DEFINE GroupPolicyAcceptHKLMTrick}
51
 
52
interface
53
 
54
uses
55
  Windows, SysUtils, Classes, ContNrs, ShellAPI, Registry, Messages;
56
 
57
const
76 daniel-mar 58
  RECBINUNIT_VERSION = '2016-07-03';
75 daniel-mar 59
 
60
  RECYCLER_CLSID: TGUID = '{645FF040-5081-101B-9F08-00AA002F954E}';
61
  NULL_GUID: TGUID      = '{00000000-0000-0000-0000-000000000000}';
62
 
63
type
64
  EAPICallError = class(Exception);
65
  EEventCategoryNotDefined = class(Exception);
66
  EInvalidDrive = class(Exception);
67
 
68
  PSHQueryRBInfo = ^TSHQueryRBInfo;
69
  TSHQueryRBInfo = packed record
76 daniel-mar 70
    cbSize      : DWORD;
75 daniel-mar 71
    i64Size     : int64;
72
    i64NumItems : int64;
73
  end;
74
 
75
  TRbRecycleBinItem = class(TObject)
76
  strict private
77
    function GetSource: string;
78
  strict protected
79
    FSourceAnsi: AnsiString;
80
    FSourceUnicode: WideString;
81
    FID: string;
82
    FSourceDrive: Char;
83
    FDeletionTime: TDateTime;
84
    FOriginalSize: int64;
85
    FIndexFile: string;
86
    FRemovedEntry: boolean;
87
    procedure ReadFromStream(stream: TStream); virtual; abstract;
88
    function GetPhysicalFile: string; virtual; abstract; // protected, because it will be read by "property"
89
  public
90
    property PhysicalFile: string read GetPhysicalFile;
91
    property SourceAnsi: AnsiString read FSourceAnsi;
92
    property SourceUnicode: WideString read FSourceUnicode;
93
    property Source: string read GetSource; // will bei either ANSI or Unicode, sepending on the Delphi version
94
    property ID: string read FID;
95
    property SourceDrive: Char read FSourceDrive;
96
    property DeletionTime: TDateTime read FDeletionTime;
97
    property OriginalSize: int64 read FOriginalSize;
98
    property IndexFile: string read FIndexFile;
99
    property RemovedEntry: boolean read FRemovedEntry; // the file is NOT in the recycle bin anymore!
100
 
101
    // Attention: There are not an official API calls. The delete and recover
102
    // functions might fail and/or damage the shell cache. Handle with care!
103
    function DeleteFile: boolean; virtual; abstract;
104
    function RecoverFile: boolean; virtual; abstract;
105
    function OpenFile: boolean; virtual; abstract;
106
  end;
107
 
76 daniel-mar 108
  TRbInfoAItem = class(TRbRecycleBinItem)
75 daniel-mar 109
  strict protected
110
    procedure ReadFromStream(stream: TStream); override;
111
    function GetPhysicalFile: string; override;
112
  public
113
    constructor Create(fs: TStream; AIndexFile: string);
114
    function DeleteFile: boolean; override;
115
    // TODO: function RecoverFile: boolean; override;
116
    // TODO: function OpenFile: boolean; override;
117
  end;
118
 
76 daniel-mar 119
  TRbInfoWItem = class(TRbRecycleBinItem)
75 daniel-mar 120
  strict protected
121
    procedure ReadFromStream(stream: TStream); override;
122
    function GetPhysicalFile: string; override;
123
  public
124
    constructor Create(fs: TStream; AIndexFile: string);
125
    function DeleteFile: boolean; override;
126
    // TODO: function RecoverFile: boolean; override;
127
    // TODO: function OpenFile: boolean; override;
128
  end;
129
 
130
  TRbVistaItem = class(TRbRecycleBinItem)
131
  strict protected
132
    procedure ReadFromStream(stream: TStream); override;
133
    function GetPhysicalFile: string; override;
134
  public
135
    constructor Create(fs: TStream; AIndexFile, AID: string);
136
    function DeleteFile: boolean; override;
137
    // TODO: function RecoverFile: boolean; override;
138
    // TODO: function OpenFile: boolean; override;
139
  end;
140
 
141
  TRbRecycleBin = class(TObject)
142
  strict private
143
    FFileOrDirectory: string;
144
    FSID: string;
76 daniel-mar 145
    FTolerantReading: boolean;
75 daniel-mar 146
  public
147
    constructor Create(AFileOrDirectory: string; ASID: string='');
148
 
149
    function GetItem(id: string): TRbRecycleBinItem;
150
    procedure ListItems(list: TObjectList{TRbRecycleBinItem});
151
    function CheckIndexes(slErrors: TStrings): boolean;
152
 
153
    property FileOrDirectory: string read FFileOrDirectory;
154
    property SID: string read FSID;
76 daniel-mar 155
 
156
    // Allows an index file to be read, even if an incompatible multiboot combination
157
    // corrupted it. Default: true.
158
    property TolerantReading: boolean read FTolerantReading write FTolerantReading;
75 daniel-mar 159
  end;
160
 
161
  // TODO: Wie sieht es aus mit Laufwerken, die nur als Mount-Point eingebunden sind?
162
  TRbDrive = class(TObject)
163
  strict private
164
    FDriveLetter: Char;
165
 
166
    // will return NULL_GUID in case of an error or if it is not supported
167
    function GetVolumeGUID: TGUID;
168
  strict protected
169
    function IsFAT: boolean;
170
    procedure CheckDriveExisting;
171
  public
172
    constructor Create(ADriveLetter: Char);
173
 
174
    // Wenn UserSID='', dann werden alle Recycler gefunden
175
    procedure ListRecycleBins(list: TObjectList{TRbRecycleBin}; UserSID: string='');
176
 
177
    property DriveLetter: Char read FDriveLetter;
178
    property VolumeGUID: TGUID read GetVolumeGUID;
179
    function GetAPIInfo: TSHQueryRBInfo;
180
    function GetSize: int64;
181
    function GetNumItems: int64;
182
    function IsEmpty: boolean;
183
 
184
    function GetMaxPercentUsage: integer;
185
    function GetNukeOnDelete: boolean;
186
 
187
    // These functions will check the global configuration and group policy, too.
188
    function RecyclerGetPercentUsageAutoDeterminate: integer;
189
    function RecyclerIsNukeOnDeleteAutoDeterminate: boolean;
190
  end;
191
 
192
  GPOLICYBOOL = (gpUndefined, gpEnabled, gpDisabled);
193
 
194
  TRecycleBinManager = class(TObject)
195
  public
196
    class procedure ListDrives(list: TObjectList{TRbDrive}); static;
197
    class function RecycleBinPossible(Drive: Char): boolean; static;
198
 
199
    class function OwnRecyclersSize: int64; static;
200
    class function OwnRecyclersNumItems: int64; static;
201
    class function OwnRecyclersEmpty: boolean; static;
202
 
203
    class function EmptyOwnRecyclers(flags: cardinal): boolean; overload; static;
204
    class function EmptyOwnRecyclers(sound, progress, confirmation: boolean): boolean; overload; static;
205
 
206
    class function RecyclerGetCurrentIconString: string; static;
207
    class function RecyclerGetDefaultIconString: string; static;
208
    class function RecyclerGetEmptyIconString: string; static;
209
    class function RecyclerGetFullIconString: string; static;
210
 
211
    class function GetGlobalMaxPercentUsage: integer; static; // TODO: In Win Vista: absolute and not relative sizes
212
    class function GetGlobalNukeOnDelete: boolean; static;
213
    class function UsesGlobalSettings: boolean; static;
214
 
215
    class function RecyclerGetName: string; static;
216
    class function RecyclerGetInfoTip: string; static;
217
    class function RecyclerGetIntroText: string; static;
218
 
219
    class function RecyclerEmptyEventGetCurrentSound: string; static;
220
    class function RecyclerEmptyEventGetDefaultSound: string; static;
221
    class function RecyclerEmptyEventGetName: string; static;
222
    class function RecyclerEmptyEventGetSound(ACategory: string): string; static;
223
    class procedure RecyclerEmptyEventGetSoundCategories(AStringList: TStringList); static;
224
 
225
    // TODO: In future also detect for other users
226
    // TODO: Also make a setter (incl. Message to Windows Explorer?)
227
    class function RecyclerGroupPolicyConfirmFileDelete: GPOLICYBOOL; static;
228
    class function RecyclerGroupPolicyNoRecycleFiles: GPOLICYBOOL; static;
229
    class function RecyclerGroupPolicyRecycleBinSize: integer; static;
230
 
231
    class function RecyclerConfirmationDialogEnabled: boolean; static;
232
    class procedure RecyclerConfirmationDialogSetEnabled(NewSetting: boolean); static;
233
    class function RecyclerShellStateConfirmationDialogEnabled: boolean; static;
234
 
235
    // Diese Funktion ist false, wenn sie z.B. unter Windows 95 ohne Internet Explorer
236
    // 4.0 Shell Extension ausgeführt wird. Wenn abwärtskompatibler Code geschrieben
237
    // werden soll, sollte RecyclerQueryFunctionAvailable() verwendet werden, da
238
    // unter Windows 95 folgende Funktionalitäten NICHT vorhanden sind:
239
    // - RecyclerIsEmpty
240
    // - RecyclerGetNumItems
241
    // - RecyclerGetSize
242
    // - RecyclerGetAPIInfo
243
    class function RecyclerQueryFunctionAvailable: boolean; static;
244
 
245
    class function RecyclerAddFileOrFolder(FileOrFolder: string; confirmation: boolean=false): boolean; static;
246
  end;
247
 
248
function GPBoolToString(value: GPOLICYBOOL): string;
249
 
250
implementation
251
 
252
uses
253
  RecBinUnitLowLvl;
254
 
255
{$REGION 'WinAPI/RTL declarations'}
256
(*
257
const
258
  {$IFDEF MSWINDOWS}
259
    shell32  = 'shell32.dll';
260
    advapi32 = 'advapi32.dll';
261
    kernel32 = 'kernel32.dll';
262
  {$ENDIF}
263
  {$IFDEF LINUX}
264
    shell32  = 'libshell32.borland.so';
265
    advapi32 = 'libwine.borland.so';
266
    kernel32 = 'libwine.borland.so';
267
  {$ENDIF}
268
*)
269
 
270
type
271
  SHELLSTATE = record
272
    Flags1: DWORD;
273
(*
274
    BOOL fShowAllObjects : 1;
275
    BOOL fShowExtensions : 1;
276
    BOOL fNoConfirmRecycle : 1;
277
 
278
    BOOL fShowSysFiles : 1;
279
    BOOL fShowCompColor : 1;
280
    BOOL fDoubleClickInWebView : 1;
281
    BOOL fDesktopHTML : 1;
282
    BOOL fWin95Classic : 1;
283
    BOOL fDontPrettyPath : 1;
284
    BOOL fShowAttribCol : 1; // No longer used, dead bit
285
    BOOL fMapNetDrvBtn : 1;
286
    BOOL fShowInfoTip : 1;
287
    BOOL fHideIcons : 1;
288
    BOOL fWebView : 1;
289
    BOOL fFilter : 1;
290
    BOOL fShowSuperHidden : 1;
291
    BOOL fNoNetCrawling : 1;
292
*)
293
    dwWin95Unused: DWORD; // Win95 only - no longer supported pszHiddenFileExts
294
    uWin95Unused: UINT; // Win95 only - no longer supported cbHiddenFileExts
295
 
296
    // Note: Not a typo!  This is a persisted structure so we cannot use LPARAM
297
    lParamSort: Integer;
298
    iSortDirection: Integer;
299
 
300
    version: UINT;
301
 
302
    // new for win2k. need notUsed var to calc the right size of ie4 struct
303
    // FIELD_OFFSET does not work on bit fields
304
    uNotUsed: UINT; // feel free to rename and use
305
    Flags2: DWORD;
306
(*
307
    BOOL fSepProcess: 1;
308
    // new for Whistler.
309
    BOOL fStartPanelOn: 1;       //Indicates if the Whistler StartPanel mode is ON or OFF.
310
    BOOL fShowStartPage: 1;      //Indicates if the Whistler StartPage on desktop is ON or OFF.
311
    UINT fSpareFlags : 13;
312
*)
313
  end;
314
  LPSHELLSTATE = ^SHELLSTATE;
315
 
316
const
317
  // Masks for the SHELLSTATE
318
  SSF_SHOWALLOBJECTS       = $00000001;
319
  SSF_SHOWEXTENSIONS       = $00000002;
320
  SSF_HIDDENFILEEXTS       = $00000004;
321
  SSF_SERVERADMINUI        = $00000004;
322
  SSF_SHOWCOMPCOLOR        = $00000008;
323
  SSF_SORTCOLUMNS          = $00000010;
324
  SSF_SHOWSYSFILES         = $00000020;
325
  SSF_DOUBLECLICKINWEBVIEW = $00000080;
326
  SSF_SHOWATTRIBCOL        = $00000100;
327
  SSF_DESKTOPHTML          = $00000200;
328
  SSF_WIN95CLASSIC         = $00000400;
329
  SSF_DONTPRETTYPATH       = $00000800;
330
  SSF_SHOWINFOTIP          = $00002000;
331
  SSF_MAPNETDRVBUTTON      = $00001000;
332
  SSF_NOCONFIRMRECYCLE     = $00008000;
333
  SSF_HIDEICONS            = $00004000;
334
  SSF_FILTER               = $00010000;
335
  SSF_WEBVIEW              = $00020000;
336
  SSF_SHOWSUPERHIDDEN      = $00040000;
337
  SSF_SEPPROCESS           = $00080000;
338
  SSF_NONETCRAWLING        = $00100000;
339
  SSF_STARTPANELON         = $00200000;
340
  SSF_SHOWSTARTPAGE        = $00400000;
341
{$ENDREGION}
342
 
343
resourcestring
344
  LNG_API_CALL_ERROR = 'Error while calling the API. Additional information: "%s".';
345
  LNG_NOT_CALLABLE = '%s not callable';
346
  LNG_ERROR_CODE = '%s (Arguments: %s) returns error code %s';
347
  LNG_FILE_NOT_FOUND = 'File not found: %s';
76 daniel-mar 348
  LNG_INVALID_INFO_FORMAT = 'Unexpected record size: %s';
75 daniel-mar 349
  LNG_DRIVE_NOT_EXISTING = 'Drive %s does not exist.';
350
 
351
const
352
  C_SHQueryRecycleBin = 'SHQueryRecycleBinA';
353
  C_GetVolumeNameForVolumeMountPoint = 'GetVolumeNameForVolumeMountPointA';
354
  C_SHEmptyRecycleBinA = 'SHEmptyRecycleBinA';
355
  C_SHGetSettings = 'SHGetSettings';
356
  C_SHGetSetSettings = 'SHGetSetSettings';
357
 
358
type
359
  TSHQueryRecycleBin = function(pszRootPath: LPCTSTR; var pSHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall;
360
  TGetVolumeNameForVolumeMountPoint = function(lpszVolumeMountPoint: LPCTSTR; lpszVolumeName: LPTSTR; cchBufferLength: DWORD): BOOL; stdcall;
361
  TSHEmptyRecycleBin = function(Wnd: HWND; pszRootPath: PChar; dwFlags: DWORD): HRESULT; stdcall;
362
  TSHGetSettings = procedure(var lpss: SHELLSTATE; dwMask: DWORD) stdcall;
363
  TSHGetSetSettings = procedure(var lpss: SHELLSTATE; dwMask: DWORD; bSet: BOOL) stdcall;
364
 
365
function GetDriveGUID(driveLetter: Char; var guid: TGUID): DWORD;
366
var
367
  Buffer: array[0..50] of AnsiChar;
368
  x: string;
369
  PGetVolumeNameForVolumeMountPoint: TGetVolumeNameForVolumeMountPoint;
370
  RBHandle: THandle;
371
begin
372
  RBHandle := LoadLibrary(kernel32);
373
  try
374
    if RBHandle <> 0 then
375
    begin
376
      PGetVolumeNameForVolumeMountPoint := GetProcAddress(RBHandle, C_GetVolumeNameForVolumeMountPoint);
377
      if not Assigned(@PGetVolumeNameForVolumeMountPoint) then
378
      begin
379
        result := GetLastError;
380
        FreeLibrary(RBHandle);
381
        RBHandle := 0;
382
      end
383
      else
384
      begin
385
        if PGetVolumeNameForVolumeMountPoint(PAnsiChar(driveLetter+':\'), Buffer, SizeOf(Buffer)) then
386
        begin
387
          x := buffer;
388
          x := copy(x, 11, 38);
389
          guid := StringToGUID(x);
390
          result := ERROR_SUCCESS;
391
        end
392
        else
393
          result := GetLastError;
394
      end;
395
    end
396
    else result := GetLastError;
397
  finally
398
    if RBHandle <> 0 then FreeLibrary(RBHandle);
399
  end;
400
end;
401
 
402
function FileTimeToDateTime(FileTime: FILETIME): TDateTime;
403
{$IFDEF FILETIME_DELPHI_CODE}
404
var
405
  SystemTime: TSystemTime;
406
  nowUTC: TDateTime;
407
  gmtDifference: int64;
408
begin
409
  GetSystemTime(SystemTime);
410
  with SystemTime do
411
  begin
412
    // http://www.delphipraxis.net/post340194.html#34019
413
    nowUTC := EncodeDate(wYear, wMonth, wDay) +
414
              EncodeTime(wHour, wMinute, wSecond, wMilliseconds);
415
  end;
416
 
417
  gmtDifference := datetimetounix(nowUTC) - datetimetounix(Now);
418
 
419
  // http://www.e-fense.com/helix/Docs/Recycler_Bin_Record_Reconstruction.pdf states:
420
  // UnixTime = 0.0000001 * NTTime + 11644473600
421
  // This is wrong! The correct formula is:
422
  // UnixTime = 0.0000001 * NTTime - 11644473600 + c * 3600
423
  // c = GMT-Difference (MEZ = 1) inclusive daylight saving time (+3600 seconds)
424
  result := unixtodatetime(round(0.0000001 * int64(FileTime)) - 11644473600 - gmtDifference);
425
{$ELSE}
426
var
427
  LocalTime: TFileTime;
428
  DOSTime: Integer;
429
begin
430
  FileTimeToLocalFileTime(FileTime, LocalTime);
431
  FileTimeToDosDateTime(LocalTime, LongRec(DOSTime).Hi, LongRec(DOSTime).Lo);
432
  Result := FileDateToDateTime(DOSTime);
433
{$ENDIF}
434
end;
435
 
436
function DeleteDirectory(const Name: string): boolean;
437
var
438
  F: TSearchRec;
439
begin
440
  result := true;
441
  if FindFirst(IncludeTrailingPathDelimiter(Name) + '*', faAnyFile, F) = 0 then
442
  begin
443
    try
444
      repeat
445
        if F.Attr and faDirectory <> 0 then
446
        begin
447
          if (F.Name <> '.') and (F.Name <> '..') then
448
          begin
449
            result := result and DeleteDirectory(IncludeTrailingPathDelimiter(Name) + F.Name);
450
          end;
451
        end
452
        else
453
        begin
454
          if not DeleteFile(IncludeTrailingPathDelimiter(Name) + F.Name) then result := false;
455
        end;
456
      until FindNext(F) <> 0;
457
    finally
458
      FindClose(F);
459
    end;
460
    if not RemoveDir(Name) then result := false;
461
  end;
462
end;
463
 
464
function DriveLetterToDriveNumber(driveLetter: Char): integer;
465
var
466
  tmp: string;
467
begin
468
  tmp := LowerCase(driveLetter);
469
  result := Ord(tmp[1])-Ord('a');
470
end;
471
 
472
function GetStringFromDLL(filename: string; num: integer): string;
473
const
474
  // Source: http://www.eggheadcafe.com/forumarchives/vcmfc/sep2005/post23917443.asp
475
  MAX_BUF = 4097; // OK?
476
var
477
  hLib: THandle;
478
  buf: array[0..MAX_BUF] of char;
479
begin
480
  hLib := LoadLibrary(PChar(filename));
481
  try
482
    LoadString(hLib, num, buf, sizeof(buf));
483
    result := buf;
484
  finally
485
    FreeLibrary(hLib);
486
  end;
487
end;
488
 
489
function ExpandEnvStr(const szInput: string): string;
490
const
491
  MAXSIZE = 32768; // laut PSDK sind 32k das Maximum
492
begin
493
  // Source: http://www.delphi-library.de/topic_Umgebungsvariable+in+einem+String+aufloesen_20516,0.html
494
  SetLength(Result,MAXSIZE);
495
  SetLength(Result,ExpandEnvironmentStrings(pchar(szInput),
496
    @Result[1],length(Result))-1); //-1 um abschließendes #0 zu verwerfen
497
end;
498
 
499
function DecodeReferenceString(s: string): string;
500
var
501
  dll, id, lang, cache: string;
502
  sl, sl2: tstringlist;
503
begin
504
  // Beispiele
505
  // Papierkorb                                                 -- Windows 95
506
  // @C:\WINNT\system32\shell32.dll,-8964@1031,Papierkorb       -- Windows 2000
507
 
508
  if Copy(s, 1, 1) = '@' then
509
  begin
510
    // Referenz auf eine DLL
511
    // @<dll>,-<id>[@<lang>][,<cache>]
512
 
513
    sl := TStringList.Create;
514
    try
515
      // '@' am Anfang entfernen
516
      s := Copy(s, 2, length(s)-1);
517
 
518
      // Nach ',' auftrennen
519
      // sl[0] --> dll
520
      // sl[1] --> -id@lang
521
      // sl[2] --> cache
522
      sl.CommaText := s;
523
 
524
      if sl.Count > 2 then
525
      begin
526
        // Das Ergebnis ist bereits im Klartext vorhanden und muss nicht extrahiert werden
527
        // Ist bei Windows 2000 der Fall
528
        cache := sl[2];
529
        result := cache;
530
        exit;
531
      end;
532
 
533
      if sl.Count > 1 then
534
      begin
535
        dll := sl[0];
536
 
537
        sl2 := TStringList.Create;
538
        try
539
          // Nach '@' auftrennen
540
          // sl2[0] --> id
541
          // sl2[1] --> lang
542
          sl2.CommaText := StringReplace(sl[1], '@', ',', [rfReplaceAll]);
543
 
544
          id := sl2[0];
545
 
546
          if sl2.Count > 1 then
547
          begin
548
            // ToDo: In Zukunft beachten, sofern möglich
549
            lang := sl2[1];
550
          end;
551
 
552
          // Umgebungsvariablen erkennen und Minuszeichen entfernen
553
          result := GetStringFromDLL(ExpandEnvStr(dll), -StrToInt(id));
554
        finally
555
          sl2.Free;
556
        end;
557
      end
558
      else
559
      begin
560
        // Zu wenige Informationen!
561
 
562
        result := '';
563
      end;
564
    finally
565
      sl.Free;
566
    end;
567
  end
568
  else
569
  begin
570
    // Kein Hinweis auf eine Referenz
571
    result := s;
572
  end;
573
end;
574
 
575
function GPBoolToString(value: GPOLICYBOOL): string;
576
begin
577
  case value of
578
    gpUndefined: result := 'Not configured';
579
    gpEnabled: result := 'Enabled';
580
    gpDisabled: result := 'Disabled';
581
  end;
582
end;
583
 
584
{ TRbRecycleBin }
585
 
586
constructor TRbRecycleBin.Create(AFileOrDirectory: string; ASID: string='');
587
begin
588
  inherited Create;
589
 
590
  FFileOrDirectory := AFileOrDirectory;
591
  FSID := ASID;
76 daniel-mar 592
  TolerantReading := true;
75 daniel-mar 593
end;
594
 
595
// TODO: also a function that tests if the data files are still existing
596
function TRbRecycleBin.CheckIndexes(slErrors: TStrings): boolean;
597
 
598
  procedure _Assert(assertion: boolean; msg: string; args: array of const);
599
  begin
600
    if not assertion then
601
    begin
602
      slErrors.Add(Format(msg, args));
603
      result := false;
604
    end;
605
  end;
606
 
607
  procedure _HandleIndexFile(AFile: string);
608
  var
609
    fs: TFileStream;
76 daniel-mar 610
    infoHdr: TRbInfoHeader;
75 daniel-mar 611
  resourcestring
612
    LNG_IDXERR_VISTA_FILESIZE = '%s: Vista index file has wrong size';
613
    LNG_IDXERR_INFO_RECSIZE_UNEXPECTED = '%s: record size unexpected';
614
    LNG_IDXERR_INFO_UNEXPECTED_EOF = '%s: file size wrong';
615
  begin
616
    fs := TFileStream.Create(AFile, fmOpenRead);
617
    try
618
      fs.Seek(0, soFromBeginning);
619
 
620
      if SameText(copy(ExtractFileName(AFile), 1, 2), '$I') then
621
      begin
622
        _Assert(fs.Size = SizeOf(TRbVistaItem), LNG_IDXERR_VISTA_FILESIZE, [AFile]);
623
      end
76 daniel-mar 624
      else if SameText(ExtractFileName(AFile), 'INFO') or
625
              SameText(ExtractFileName(AFile), 'INFO2') then
75 daniel-mar 626
      begin
627
        fs.ReadBuffer(infoHdr, SizeOf(infoHdr));
76 daniel-mar 628
        _Assert((infoHdr.recordLength = SizeOf(TRbInfoRecordA)) or
629
                (infoHdr.recordLength = SizeOf(TRbInfoRecordW)), LNG_IDXERR_INFO_RECSIZE_UNEXPECTED, [AFile]);
75 daniel-mar 630
        _Assert((fs.Size-fs.Position) mod infoHdr.recordLength = 0, LNG_IDXERR_INFO_UNEXPECTED_EOF, [AFile]);
76 daniel-mar 631
        // TODO: we can also check infoHdr.totalSize or infoHdr.totalEntries
75 daniel-mar 632
      end
76 daniel-mar 633
      else Assert(false);
75 daniel-mar 634
 
635
      // TODO: we could check each item for invalid stuff...?
636
    finally
637
      FreeAndNil(fs);
638
    end;
639
  end;
640
 
641
  procedure _HandleVistaDir(ADirectory: string);
642
  var
643
    SR: TSearchRec;
644
  begin
645
    ADirectory := IncludeTrailingPathDelimiter(ADirectory);
646
 
647
    if FindFirst(ADirectory + '$I*', faAnyFile, SR) = 0 then
648
    begin
649
      repeat
650
        _HandleIndexFile(ADirectory+sr.Name);
651
      until FindNext(SR) <> 0;
652
    end;
653
    FindClose(SR);
654
  end;
655
 
656
begin
657
  result := true;
658
 
659
  if DirectoryExists(FFileOrDirectory) then // Vista, as well as directories with INFO and INFO2
660
  begin
661
    _HandleVistaDir(FFileOrDirectory);
662
 
663
    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2') then
664
    begin
665
      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2');
666
    end;
667
 
668
    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO') then
669
    begin
670
      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO');
671
    end;
672
  end
673
  else if FileExists(FFileOrDirectory) then
674
  begin
675
    _HandleIndexFile(FFileOrDirectory);
676
  end
677
  else raise Exception.CreateFmt(LNG_FILE_NOT_FOUND, [FFileOrDirectory]);
678
end;
679
 
680
function TRbRecycleBin.GetItem(id: string): TRbRecycleBinItem;
681
 
682
  procedure _HandleIndexFile(AFile: string);
683
  var
684
    fs: TFileStream;
76 daniel-mar 685
    infoHdr: TRbInfoHeader;
75 daniel-mar 686
    testItem: TRbRecycleBinItem;
687
  begin
688
    fs := TFileStream.Create(AFile, fmOpenRead);
689
    try
690
      fs.Seek(0, soFromBeginning);
691
 
692
      if fs.Size = SizeOf(TRbVistaRecord) then
693
      begin
694
        if SameText(ExtractFileName(AFile), '$I'+id) then
695
        begin
696
          result := TRbVistaItem.Create(fs, AFile, id);
697
        end;
698
      end
699
      else
700
      begin
701
        fs.ReadBuffer(infoHdr, SizeOf(infoHdr));
702
        case infoHdr.recordLength of
76 daniel-mar 703
          SizeOf(TRbInfoRecordA):
75 daniel-mar 704
          begin
705
            while fs.Position < fs.size do
706
            begin
76 daniel-mar 707
              testItem := TRbInfoAItem.Create(fs, AFile);
75 daniel-mar 708
              if testItem.ID = id then
709
              begin
710
                result := testItem;
711
                break;
712
              end;
713
            end;
714
          end;
76 daniel-mar 715
          SizeOf(TRbInfoRecordW):
75 daniel-mar 716
          begin
717
            while fs.Position < fs.size do
718
            begin
76 daniel-mar 719
              testItem := TRbInfoWItem.Create(fs, AFile);
75 daniel-mar 720
              if testItem.ID = id then
721
              begin
722
                result := testItem;
723
                break;
724
              end;
725
            end;
726
          end
727
          else
728
          begin
729
            raise Exception.CreateFmt(LNG_INVALID_INFO_FORMAT, [AFile]);
730
          end;
731
        end;
732
      end;
733
    finally
734
      FreeAndNil(fs);
735
    end;
736
  end;
737
 
738
  procedure _HandleVistaDir(ADirectory: string);
739
  var
740
    SR: TSearchRec;
741
    fs: TFileStream;
742
    id: string;
743
  begin
744
    ADirectory := IncludeTrailingPathDelimiter(ADirectory);
745
 
746
    if FileExists(ADirectory + '$I' + id) then
747
    begin
748
      fs := TFileStream.Create(ADirectory+sr.Name, fmOpenRead);
749
      try
750
        fs.Seek(0, soFromBeginning);
751
        result := TRbVistaItem.Create(fs, ADirectory+sr.Name, id);
752
      finally
753
        FreeAndNil(fs);
754
      end;
755
    end;
756
  end;
757
 
758
begin
759
  result := nil;
760
 
761
  if DirectoryExists(FFileOrDirectory) then // Vista, as well as directories with INFO and INFO2
762
  begin
763
    _HandleVistaDir(FFileOrDirectory);
764
    if Assigned(result) then exit;
765
 
766
    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2') then
767
    begin
768
      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2');
769
      if Assigned(result) then exit;
770
    end;
771
 
772
    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO') then
773
    begin
774
      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO');
775
      if Assigned(result) then exit;
776
    end;
777
  end
778
  else if FileExists(FFileOrDirectory) then
779
  begin
780
    _HandleIndexFile(FFileOrDirectory);
781
    if Assigned(result) then exit;
782
  end
783
  else raise Exception.CreateFmt(LNG_FILE_NOT_FOUND, [FFileOrDirectory]);
784
end;
785
 
786
procedure TRbRecycleBin.ListItems(list: TObjectList{TRbRecycleBinItem});
787
 
788
  procedure _HandleIndexFile(AFile: string);
789
  var
790
    fs: TFileStream;
76 daniel-mar 791
    infoHdr: TRbInfoHeader;
75 daniel-mar 792
    testID: string;
76 daniel-mar 793
    wTest: TRbInfoWItem;
794
    bakPosition: int64;
75 daniel-mar 795
  begin
796
    fs := TFileStream.Create(AFile, fmOpenRead);
797
    try
798
      fs.Seek(0, soFromBeginning);
799
 
800
      if fs.Size = SizeOf(TRbVistaRecord) then
801
      begin
802
        testID := ExtractFileName(AFile);
803
        if SameText(copy(testID, 1, 2), '$I') then
804
          testID := copy(testID, 3, Length(testID)-2)
805
        else
76 daniel-mar 806
          testID := ''; // Just in case the user wants to read a single Vista file, but without the $I name
75 daniel-mar 807
 
808
        list.Add(TRbVistaItem.Create(fs, AFile, testID));
809
      end
810
      else
811
      begin
76 daniel-mar 812
        if TolerantReading then
813
        begin
814
          // This is a special treatment how to recover data from an INFO/INFO2 file
815
          // which was corrupted by an incompatible multiboot configuration.
816
          // Example:
817
          // - Win95 without IE4 and WinNT4 both write into the INFO file. But Win95 appends the ANSI record and WinNT appends an Unicode record.
818
          // - 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.
819
          fs.ReadBuffer(infoHdr, SizeOf(infoHdr));
820
          while fs.Position < fs.size do
75 daniel-mar 821
          begin
76 daniel-mar 822
            // Can we actually read a Unicode record?
823
            if fs.Position + SizeOf(TRbInfoRecordW) <= fs.Size then
75 daniel-mar 824
            begin
76 daniel-mar 825
              // Try to read the Unicode record and check if it is valid
826
              // In case it is no Unicode record, then the Unicode part will be the
827
              // ANSI source name of the next record. In this case, we won't get
828
              // a ':' at the Unicode string.
829
              bakPosition := fs.Position;
830
              wTest := TRbInfoWItem.Create(fs, AFile);
831
              if Copy(wTest.SourceUnicode, 2, 1) = ':' then
832
              begin
833
                // Yes, it is a valid Unicode record.
834
                list.Add(wTest);
835
              end
836
              else
837
              begin
838
                // No, it is not a valid Unicode record. Jump back, and we need
839
                // to assume that the following record will be a valid ANSI record.
840
                fs.Position := bakPosition;
841
                list.Add(TRbInfoAItem.Create(fs, AFile));
842
              end;
843
            end
844
            else
845
            begin
846
              // No, there is not enough space left for an Unicode record.
847
              // So we assume that the following record will be a valid ANSI record.
848
              list.Add(TRbInfoAItem.Create(fs, AFile));
75 daniel-mar 849
            end;
850
          end;
76 daniel-mar 851
        end
852
        else
853
        begin
854
          // This is the code for non-tolerant reading of the records.
855
          fs.ReadBuffer(infoHdr, SizeOf(infoHdr));
856
          case infoHdr.recordLength of
857
            SizeOf(TRbInfoRecordA):
75 daniel-mar 858
            begin
76 daniel-mar 859
              while fs.Position < fs.size do
860
              begin
861
                list.Add(TRbInfoAItem.Create(fs, AFile));
862
              end;
75 daniel-mar 863
            end;
76 daniel-mar 864
            SizeOf(TRbInfoRecordW):
865
            begin
866
              while fs.Position < fs.size do
867
              begin
868
                list.Add(TRbInfoWItem.Create(fs, AFile));
869
              end;
870
            end
871
            else
872
            begin
873
              raise Exception.CreateFmt(LNG_INVALID_INFO_FORMAT, [AFile]);
874
            end;
75 daniel-mar 875
          end;
876
        end;
877
      end;
878
    finally
879
      FreeAndNil(fs);
880
    end;
881
  end;
882
 
883
  procedure _HandleVistaDir(ADirectory: string);
884
  var
885
    SR: TSearchRec;
886
    fs: TFileStream;
887
    id: string;
888
  begin
889
    ADirectory := IncludeTrailingPathDelimiter(ADirectory);
890
 
891
    if FindFirst(ADirectory + '$I*', faAnyFile, SR) = 0 then
892
    begin
893
      repeat
894
        id := sr.Name;
895
        { 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
896
        id := Copy(id, 3, Length(id)-2);
897
 
898
        fs := TFileStream.Create(ADirectory+sr.Name, fmOpenRead);
899
        try
900
          fs.Seek(0, soFromBeginning);
901
          list.Add(TRbVistaItem.Create(fs, ADirectory+sr.Name, id));
902
        finally
903
          FreeAndNil(fs);
904
        end;
905
      until FindNext(SR) <> 0;
906
    end;
907
    FindClose(SR);
908
  end;
909
 
910
begin
911
  if DirectoryExists(FFileOrDirectory) then // Vista, as well as directories with INFO and INFO2
912
  begin
913
    _HandleVistaDir(FFileOrDirectory);
914
 
915
    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2') then
916
    begin
917
      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO2');
918
    end;
919
 
920
    if FileExists(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO') then
921
    begin
922
      _HandleIndexFile(IncludeTrailingPathDelimiter(FFileOrDirectory) + 'INFO');
923
    end;
924
  end
925
  else if FileExists(FFileOrDirectory) then
926
  begin
76 daniel-mar 927
    _HandleIndexFile(FFileOrDirectory); // Either INFO, or INFO2, or a single Vista index file
75 daniel-mar 928
  end
929
  else raise Exception.CreateFmt(LNG_FILE_NOT_FOUND, [FFileOrDirectory]);
930
end;
931
 
932
{ TRbDrive }
933
 
934
procedure TRbDrive.CheckDriveExisting;
935
begin
936
  // Does the drive exist?
937
  // see http://www.delphipraxis.net/post2933.html
938
  if not GetLogicalDrives and (1 shl DriveLetterToDriveNumber(FDriveLetter)) <> 0 then
939
  begin
940
    raise EInvalidDrive.CreateFmt(LNG_DRIVE_NOT_EXISTING, [UpperCase(FDriveLetter)+':']);
941
  end;
942
end;
943
 
944
constructor TRbDrive.Create(ADriveLetter: Char);
945
begin
946
  inherited Create;
947
 
948
  FDriveLetter := ADriveLetter;
949
  CheckDriveExisting;
950
end;
951
 
952
function TRbDrive.GetAPIInfo: TSHQueryRBInfo;
953
var
954
  PSHQueryRecycleBin: TSHQueryRecycleBin;
955
  RBHandle: THandle;
956
  res: HRESULT;
957
  Path: string;
958
begin
959
  Path := FDriveLetter + ':\';
960
 
961
  // Ref: http://www.delphipraxis.net/post1291.html
962
 
963
  RBHandle := LoadLibrary(shell32);
964
  try
965
    PSHQueryRecycleBin := nil;
966
    if RBHandle <> 0 then
967
    begin
968
      PSHQueryRecycleBin := GetProcAddress(RBHandle, C_SHQueryRecycleBin);
969
      if not Assigned(@PSHQueryRecycleBin) then
970
      begin
971
        FreeLibrary(RBHandle);
972
        RBHandle := 0;
973
      end;
974
    end;
975
 
976
    FillChar(result, SizeOf(TSHQueryRBInfo), 0);
977
    result.cbSize := SizeOf(TSHQueryRBInfo);
978
 
979
    if (RBHandle <> 0) and Assigned(PSHQueryRecycleBin) then
980
    begin
981
      res := PSHQueryRecycleBin(PChar(Path), result);
982
      // if Succeeded(res) then
983
      if res = S_OK then
984
      begin
985
        // Alles OK, unser result hat nun die gewünschten Daten.
986
      end
987
      else
988
      begin
989
        // Since Windows Vista, SHQueryRecycleBin will fail with E_FAIL (80004005)
990
        // if Path is a floppy or CD drive...
991
        raise EAPICallError.CreateFmt(LNG_API_CALL_ERROR, [Format(LNG_ERROR_CODE, [C_SHQueryRecycleBin, Path, '0x'+IntToHex(res, 2*SizeOf(HRESULT))])]);
992
      end;
993
    end
994
    else
995
      raise EAPICallError.CreateFmt(LNG_API_CALL_ERROR, [Format(LNG_NOT_CALLABLE, [C_SHQueryRecycleBin])]);
996
  finally
997
    if RBHandle <> 0 then FreeLibrary(RBHandle);
998
  end;
999
end;
1000
 
1001
function TRbDrive.GetMaxPercentUsage: integer;
1002
var
1003
  reg: TRegistry;
1004
  purgeInfo: TRbWin95PurgeInfo;
1005
const
1006
  RES_DEFAULT = 10; // Windows 95 - Standardwert
1007
begin
1008
  result := RES_DEFAULT;
1009
 
1010
  reg := TRegistry.Create;
1011
  try
1012
    reg.RootKey := HKEY_LOCAL_MACHINE;
1013
 
1014
    // Im Auslieferungszustand von Windows 95 ist dieser Schlüssel nicht vorhanden.
1015
    // Er wird bei der ersten Änderung der Papierkorb-Einstellungen erstellt.
1016
    if reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\BitBucket') then
1017
    begin
1018
      if reg.OpenKeyReadOnly(FDriveLetter) then
1019
      begin
1020
        if reg.ValueExists('Percent') then
1021
        begin
1022
          // Windows 2000 - Informationen liegen aufgeschlüsselt in der Registry
1023
 
1024
          result := reg.ReadInteger('Percent');
1025
        end;
1026
      end
1027
      else
1028
      begin
1029
        if reg.ValueExists('PurgeInfo') then
1030
        begin
1031
          // Windows 95 - Kodierte Informationen liegen in PurgeInfo
1032
 
1033
          reg.ReadBinaryData('PurgeInfo', purgeInfo, SizeOf(purgeInfo));
1034
 
1035
          result := purgeInfo.percentDrive[FDriveLetter];
1036
        end;
1037
      end;
1038
 
1039
      reg.CloseKey;
1040
    end;
1041
  finally
1042
    reg.Free;
1043
  end;
1044
end;
1045
 
1046
function TRbDrive.RecyclerGetPercentUsageAutoDeterminate: integer;
1047
var
1048
  gpSetting: integer;
1049
begin
1050
  gpSetting := TRecycleBinManager.RecyclerGroupPolicyRecycleBinSize;
1051
  if gpSetting <> -1 then
1052
    result := gpSetting
1053
  else if TRecycleBinManager.UsesGlobalSettings then
1054
    result := TRecycleBinManager.GetGlobalMaxPercentUsage
1055
  else
1056
    result := GetMaxPercentUsage;
1057
end;
1058
 
1059
function TRbDrive.RecyclerIsNukeOnDeleteAutoDeterminate: boolean;
1060
begin
1061
  if TRecycleBinManager.RecyclerGroupPolicyNoRecycleFiles = gpEnabled then
1062
    result := true
1063
  else if TRecycleBinManager.UsesGlobalSettings then
1064
    result := TRecycleBinManager.GetGlobalNukeOnDelete
1065
  else
1066
    result := GetNukeOnDelete;
1067
end;
1068
 
1069
function TRbDrive.GetNukeOnDelete: boolean;
1070
var
1071
  reg: TRegistry;
1072
  purgeInfo: TRbWin95PurgeInfo;
1073
const
1074
  RES_DEFAULT = false; // Windows 95 - Standardwert
1075
begin
1076
  result := RES_DEFAULT;
1077
 
1078
  reg := TRegistry.Create;
1079
  try
1080
    reg.RootKey := HKEY_LOCAL_MACHINE;
1081
 
1082
    // Im Auslieferungszustand von Windows 95 ist dieser Schlüssel nicht vorhanden.
1083
    // Er wird bei der ersten Änderung der Papierkorb-Einstellungen erstellt.
1084
    if reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\BitBucket') then
1085
    begin
1086
      if reg.OpenKeyReadOnly(FDriveLetter) then
1087
      begin
1088
        if reg.ValueExists('NukeOnDelete') then
1089
        begin
1090
          // Windows 2000 - Informationen liegen aufgeschlüsselt in der Registry
1091
 
1092
          result := reg.ReadBool('NukeOnDelete');
1093
        end;
1094
      end
1095
      else
1096
      begin
1097
        if reg.ValueExists('PurgeInfo') then
1098
        begin
1099
          // Windows 95 - Kodierte Informationen liegen in PurgeInfo
1100
 
1101
          reg.ReadBinaryData('PurgeInfo', purgeInfo, SizeOf(purgeInfo));
1102
 
1103
          result := ((purgeInfo.NukeOnDeleteBits shr DriveLetterToDriveNumber(FDriveLetter)) and 1) = 1;
1104
        end;
1105
      end;
1106
 
1107
      reg.CloseKey;
1108
    end;
1109
  finally
1110
    reg.Free;
1111
  end;
1112
end;
1113
 
1114
function TRbDrive.GetNumItems: int64;
1115
begin
1116
  result := GetAPIInfo.i64NumItems;
1117
end;
1118
 
1119
function TRbDrive.GetSize: int64;
1120
begin
1121
  result := GetAPIInfo.i64Size;
1122
end;
1123
 
1124
function TRbDrive.GetVolumeGUID: TGUID;
1125
begin
1126
  if GetDriveGUID(FDriveLetter, result) <> ERROR_SUCCESS then
1127
  begin
1128
    result := NULL_GUID;
1129
  end;
1130
end;
1131
 
1132
function TRbDrive.IsEmpty: boolean;
1133
begin
1134
  result := GetNumItems = 0;
1135
end;
1136
 
1137
function TRbDrive.IsFAT: boolean;
1138
var
1139
  Dummy2: DWORD;
1140
  Dummy3: DWORD;
1141
  FileSystem: array[0..MAX_PATH] of char;
1142
  VolumeName: array[0..MAX_PATH] of char;
1143
  s: string;
1144
begin
1145
  s := FDriveLetter + DriveDelim + PathDelim; // ohne die Auslagerung in einen String kommt es zu einer AV in ntdll
1146
  GetVolumeInformation(PChar(s), VolumeName,
1147
    SizeOf(VolumeName), nil, Dummy2, Dummy3, FileSystem, SizeOf(FileSystem));
1148
  result := uppercase(copy(FileSystem, 0, 3)) = 'FAT';
1149
end;
1150
 
1151
procedure TRbDrive.ListRecycleBins(list: TObjectList{TRbRecycleBin}; UserSID: string='');
1152
 
1153
  procedure _AddSIDFolders(dir: string; wholeFolder: boolean);
1154
  var
1155
    SR: TSearchRec;
1156
  begin
1157
    dir := IncludeTrailingPathDelimiter(dir);
1158
    if FindFirst(dir+'S-*', faAnyFile, SR) = 0 then
1159
    begin
1160
      try
1161
        repeat
1162
          if (SR.Name = '.') or (SR.Name = '..') or not DirectoryExists(dir + SR.Name) then continue;
1163
 
1164
          if wholeFolder then
1165
          begin
1166
            // Vista
1167
            list.Add(TRbRecycleBin.Create(dir+SR.Name, SR.Name));
1168
          end
1169
          else
1170
          begin
1171
            // Win95 .. WinXP
1172
            if FileExists(IncludeTrailingPathDelimiter(dir+SR.Name) + 'INFO2') then
1173
              list.Add(TRbRecycleBin.Create(IncludeTrailingPathDelimiter(dir+SR.Name) + 'INFO2', SR.Name));
1174
            if FileExists(IncludeTrailingPathDelimiter(dir+SR.Name) + 'INFO') then
1175
              list.Add(TRbRecycleBin.Create(IncludeTrailingPathDelimiter(dir+SR.Name) + 'INFO', SR.Name));
1176
          end;
1177
        until FindNext(SR) <> 0;
1178
      finally
1179
        FindClose(SR);
1180
      end;
1181
    end;
1182
  end;
1183
 
1184
var
1185
  dir: string;
1186
begin
1187
  // Find recyclers from Windows Vista or higher
1188
 
1189
  if IsFAT then
1190
  begin
1191
    dir := FDriveLetter + DriveDelim + PathDelim + '$recycle.bin' + PathDelim;
1192
    if DirectoryExists(dir) then
1193
    begin
1194
      list.Add(TRbRecycleBin.Create(dir));
1195
    end;
1196
  end
1197
  else
1198
  begin
1199
    if UserSID <> '' then
1200
    begin
1201
      dir := FDriveLetter + DriveDelim + PathDelim + '$recycle.bin' + PathDelim + UserSID + PathDelim;
1202
      if DirectoryExists(dir) then
1203
      begin
1204
        list.Add(TRbRecycleBin.Create(dir, UserSID));
1205
      end;
1206
    end
1207
    else
1208
    begin
1209
      _AddSIDFolders(FDriveLetter + DriveDelim + PathDelim + '$recycle.bin', true);
1210
    end;
1211
  end;
1212
 
1213
  // Find recyclers from Windows before Vista
1214
 
1215
  if IsFAT then
1216
  begin
1217
    dir := FDriveLetter + DriveDelim + PathDelim + 'Recycled' + PathDelim;
1218
 
1219
    // Both "recycle bins" are possible if you have multiboot (but do overwrite themselfes if you empty them)
1220
    if FileExists(dir + 'INFO2') then
76 daniel-mar 1221
      list.Add(TRbRecycleBin.Create(dir + 'INFO2')); // Windows 95 with Internet Explorer 4 Extension or higher Windows 9x versions
75 daniel-mar 1222
    if FileExists(dir + 'INFO') then
1223
      list.Add(TRbRecycleBin.Create(dir + 'INFO')); // Windows 95 native
1224
  end
1225
  else
1226
  begin
1227
    if UserSID <> '' then
1228
    begin
1229
      dir := FDriveLetter + DriveDelim + PathDelim + 'Recycler' + PathDelim + UserSID + PathDelim;
1230
 
1231
      if FileExists(dir + 'INFO2') then
76 daniel-mar 1232
        list.Add(TRbRecycleBin.Create(dir + 'INFO2', UserSID)); // Windows 2000+
75 daniel-mar 1233
      if FileExists(dir + 'INFO') then
1234
        list.Add(TRbRecycleBin.Create(dir + 'INFO', UserSID)); // Windows NT 4
1235
    end
1236
    else
1237
    begin
1238
      _AddSIDFolders(FDriveLetter + DriveDelim + PathDelim + 'Recycler', false);
1239
    end;
1240
  end;
1241
end;
1242
 
76 daniel-mar 1243
{ TRbInfoAItem }
75 daniel-mar 1244
 
76 daniel-mar 1245
procedure TRbInfoAItem.ReadFromStream(stream: TStream);
75 daniel-mar 1246
var
76 daniel-mar 1247
  r: TRbInfoRecordA;
75 daniel-mar 1248
begin
1249
  stream.ReadBuffer(r, SizeOf(r));
1250
 
1251
  FSourceDrive := Chr(Ord('A') + r.sourceDrive);
1252
 
76 daniel-mar 1253
  // Win95 with IE4 and Win2000+:
1254
  // Wenn ein Eintrag aus der INFO/INFO2 gelöscht wird, dann wird das erste Byte
1255
  // von sourceAnsi auf Null gesetzt, damit die ganze INFO/INFO2 Datei nicht
1256
  // ständig neu geschrieben werden muss (so wie es bei Win95 und WinNT4 der Fall war).
1257
  // Wir lesen den Eintrag trotzdem, da unsere Software ja auch zu forensischen
1258
  // Zwecken eingesetzt werden soll.
75 daniel-mar 1259
  if r.sourceAnsi[0] = #0 then
1260
  begin
1261
    FRemovedEntry := true;
1262
    r.sourceAnsi[0] := FSourceDrive;
1263
  end;
1264
 
1265
  FSourceAnsi := r.sourceAnsi;
1266
  FSourceUnicode := r.sourceAnsi; // Unicode does not exist in INFO(1) structure
1267
  FID := IntToStr(r.recordNumber);
1268
  FDeletionTime := FileTimeToDateTime(r.deletionTime);
1269
  FOriginalSize := r.originalSize;
1270
end;
1271
 
76 daniel-mar 1272
function TRbInfoAItem.DeleteFile: boolean;
75 daniel-mar 1273
var
1274
  r: string;
1275
begin
1276
  r := GetPhysicalFile;
1277
  if DirectoryExists(r) then
1278
    result := DeleteDirectory(r) // Usually, the old recycle bin does not allow folders. Just to be sure, we include the code.
1279
  else
1280
    result := SysUtils.DeleteFile(r); // TODO: geht das oder gibt es zugriffsverletzung? --> Win95: Funktioniert
1281
 
1282
  // TODO: nun auch den eintrag aus der INFO-Datei rausschmeißen (Datei neu schreiben)
1283
end;
1284
 
76 daniel-mar 1285
function TRbInfoAItem.GetPhysicalFile: string;
75 daniel-mar 1286
begin
1287
  if FRemovedEntry then
1288
  begin
1289
    result := '';
1290
    Exit;
1291
  end;
1292
 
1293
  // e.g. C:\...\DC0.doc
1294
  result := IncludeTrailingPathDelimiter(ExtractFilePath(IndexFile)) +
76 daniel-mar 1295
            'D' + (* SourceDrive *) SourceAnsi[1] + ID + ExtractFileExt(SourceAnsi);
75 daniel-mar 1296
end;
1297
 
76 daniel-mar 1298
constructor TRbInfoAItem.Create(fs: TStream; AIndexFile: string);
75 daniel-mar 1299
begin
1300
  inherited Create;
1301
  ReadFromStream(fs);
1302
  FIndexFile := AIndexFile;
1303
end;
1304
 
76 daniel-mar 1305
{ TRbInfoWItem }
75 daniel-mar 1306
 
76 daniel-mar 1307
procedure TRbInfoWItem.ReadFromStream(stream: TStream);
75 daniel-mar 1308
var
76 daniel-mar 1309
  r: TRbInfoRecordW;
75 daniel-mar 1310
begin
1311
  stream.ReadBuffer(r, SizeOf(r));
1312
 
76 daniel-mar 1313
  // Win95 with IE4 and Win2000+:
1314
  // Wenn ein Eintrag aus der INFO/INFO2 gelöscht wird, dann wird das erste Byte
1315
  // von sourceAnsi auf Null gesetzt, damit die ganze INFO/INFO2 Datei nicht
1316
  // ständig neu geschrieben werden muss (so wie es bei Win95 und WinNT4 der Fall war).
75 daniel-mar 1317
  // Wir lesen den Eintrag trotzdem, da unsere Software ja auch zu forensischen
1318
  // Zwecken eingesetzt werden soll.
1319
  if r.sourceAnsi[0] = #0 then
1320
  begin
1321
    FRemovedEntry := true;
1322
    r.sourceAnsi[0] := AnsiChar(r.sourceUnicode[0]);
1323
  end;
1324
 
1325
  FSourceAnsi := r.sourceAnsi;
1326
  FSourceUnicode := r.sourceUnicode;
1327
  FID := IntToStr(r.recordNumber);
1328
  FSourceDrive := Chr(Ord('A') + r.sourceDrive);
1329
  FDeletionTime := FileTimeToDateTime(r.deletionTime);
1330
  FOriginalSize := r.originalSize;
1331
end;
1332
 
76 daniel-mar 1333
function TRbInfoWItem.DeleteFile: boolean;
75 daniel-mar 1334
var
1335
  r: string;
1336
begin
1337
  r := GetPhysicalFile;
1338
  if DirectoryExists(r) then
1339
    result := DeleteDirectory(r)
1340
  else
1341
    result := SysUtils.DeleteFile(r); // TODO: geht das oder gibt es zugriffsverletzung?
1342
 
1343
  // TODO: nun auch den eintrag aus der INFO-Datei rausschmeißen (Erstes Byte auf 0 setzen)
1344
end;
1345
 
76 daniel-mar 1346
function TRbInfoWItem.GetPhysicalFile: string;
75 daniel-mar 1347
begin
1348
  if FRemovedEntry then
1349
  begin
1350
    result := '';
1351
    Exit;
1352
  end;
1353
 
76 daniel-mar 1354
  (*
1355
  This is actually a bit tricky...
1356
  Win95 will choose the first letter of the AnsiSource name.
1357
  WinNT will choose the first letter of the UnicodeSource name.
1358
  WinXP will choose the driveNumber member.
1359
 
1360
  Windows XP is kinda buggy when it comes to changing a drive letter.
1361
  For example, the drive E: was changed to K:
1362
  The drive letter is 04 (E), the Source name begins with E:\ and the physical file is De0.txt .
1363
  After the recycle bin is opened the first time:
1364
  - The recycle bin will show the file origin as K:\ and not as E:\
1365
  - The file was renamed from De0.txt to Dk0.txt
1366
  - The file can be recovered at this time
1367
  When the recycle bin is closed, the INFO2 file will not be corrected (which is a bug).
1368
  So, if you open the recycle bin again, the record will be marked
1369
  as deleted in the INFO file (the first byte will be set to 0),
1370
  because Windows searches for De0.txt and doesn't find it.
1371
 
1372
  (This comment also applies to TRbInfoAItem.GetPhysicalFile)
1373
  *)
1374
 
75 daniel-mar 1375
  // e.g. C:\...\DC0.doc
1376
  result := IncludeTrailingPathDelimiter(ExtractFilePath(IndexFile)) +
76 daniel-mar 1377
            'D' + SourceDrive (* SourceUnicode[1] *) + ID + ExtractFileExt(SourceUnicode);
75 daniel-mar 1378
end;
1379
 
76 daniel-mar 1380
constructor TRbInfoWItem.Create(fs: TStream; AIndexFile: string);
75 daniel-mar 1381
begin
1382
  inherited Create;
1383
  ReadFromStream(fs);
1384
  FIndexFile := AIndexFile;
1385
end;
1386
 
1387
{ TRbVistaItem }
1388
 
1389
procedure TRbVistaItem.ReadFromStream(stream: TStream);
1390
var
1391
  r: TRbVistaRecord;
1392
begin
1393
  stream.ReadBuffer(r, SizeOf(r));
1394
 
1395
  FSourceAnsi := AnsiString(r.sourceUnicode); // Invalid chars are automatically converted into '?'
1396
  FSourceUnicode := r.sourceUnicode;
1397
  FID := ''; // will be added manually (at the constructor)
1398
  FSourceDrive := AnsiChar(r.sourceUnicode[1]);
1399
  FDeletionTime := FileTimeToDateTime(r.deletionTime);
1400
  FOriginalSize := r.originalSize;
1401
end;
1402
 
1403
function TRbVistaItem.DeleteFile: boolean;
1404
var
1405
  r: string;
1406
begin
1407
  r := GetPhysicalFile;
1408
  if DirectoryExists(r) then
1409
    result := DeleteDirectory(r)
1410
  else
1411
    result := SysUtils.DeleteFile(r);
1412
 
1413
  SysUtils.DeleteFile(FIndexFile);
1414
end;
1415
 
1416
function TRbVistaItem.GetPhysicalFile: string;
1417
begin
1418
  result := FIndexFile;
1419
  result := StringReplace(Result, '$I', '$R', [rfIgnoreCase]);
1420
end;
1421
 
1422
constructor TRbVistaItem.Create(fs: TStream; AIndexFile, AID: string);
1423
begin
1424
  inherited Create;
1425
  ReadFromStream(fs);
1426
  FIndexFile := AIndexFile;
1427
  FID := AID;
1428
end;
1429
 
1430
{ TRecycleBinManager }
1431
 
1432
class function TRecycleBinManager.EmptyOwnRecyclers(flags: cardinal): boolean;
1433
var
1434
  PSHEmptyRecycleBin: TSHEmptyRecycleBin;
1435
  LibHandle: THandle;
1436
begin
1437
  // Source: http://www.dsdt.info/tipps/?id=176
1438
  result := true;
1439
  LibHandle := LoadLibrary(shell32);
1440
  try
1441
    if LibHandle <> 0 then
1442
    begin
1443
      @PSHEmptyRecycleBin := GetProcAddress(LibHandle, C_SHEmptyRecycleBinA);
1444
      if @PSHEmptyRecycleBin <> nil then
1445
      begin
1446
        PSHEmptyRecycleBin(hInstance, nil, flags);
1447
      end
1448
      else
1449
        result := false;
1450
    end
1451
    else
1452
      result := false;
1453
  finally
1454
    @PSHEmptyRecycleBin := nil;
1455
    if LibHandle <> 0 then FreeLibrary(LibHandle);
1456
  end;
1457
end;
1458
 
1459
class function TRecycleBinManager.EmptyOwnRecyclers(sound, progress, confirmation: boolean): boolean;
1460
const
1461
  SHERB_NOCONFIRMATION = $00000001;
1462
  SHERB_NOPROGRESSUI   = $00000002;
1463
  SHERB_NOSOUND        = $00000004;
1464
var
1465
  flags: cardinal;
1466
begin
1467
  flags := 0;
1468
 
1469
  if not progress then
1470
    flags := flags or SHERB_NOPROGRESSUI;
1471
  if not confirmation then
1472
    flags := flags or SHERB_NOCONFIRMATION;
1473
  if not sound then
1474
    flags := flags or SHERB_NOSOUND;
1475
 
1476
  result := EmptyOwnRecyclers(flags);
1477
end;
1478
 
1479
class function TRecycleBinManager.GetGlobalMaxPercentUsage: integer;
1480
var
1481
  reg: TRegistry;
1482
  purgeInfo: TRbWin95PurgeInfo;
1483
const
1484
  RES_DEFAULT = 10; // Windows 95 - Standardwert
1485
begin
1486
  result := RES_DEFAULT;
1487
 
1488
  reg := TRegistry.Create;
1489
  try
1490
    reg.RootKey := HKEY_LOCAL_MACHINE;
1491
 
1492
    // Im Auslieferungszustand von Windows 95 ist dieser Schlüssel nicht vorhanden.
1493
    // Er wird bei der ersten Änderung der Papierkorb-Einstellungen erstellt.
1494
    if reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\BitBucket') then
1495
    begin
1496
      if reg.ValueExists('Percent') then
1497
      begin
1498
        // Windows 2000 - Informationen liegen aufgeschlüsselt in der Registry
1499
 
1500
        result := reg.ReadInteger('Percent');
1501
      end
1502
      else if reg.ValueExists('PurgeInfo') then
1503
      begin
1504
        // Windows 95 - Kodierte Informationen liegen in PurgeInfo
1505
 
1506
        reg.ReadBinaryData('PurgeInfo', purgeInfo, SizeOf(purgeInfo));
1507
        result := purgeInfo.percentGlobal;
1508
      end;
1509
 
1510
      reg.CloseKey;
1511
    end;
1512
  finally
1513
    reg.Free;
1514
  end;
1515
end;
1516
 
1517
class function TRecycleBinManager.GetGlobalNukeOnDelete: boolean;
1518
var
1519
  reg: TRegistry;
1520
  purgeInfo: TRbWin95PurgeInfo;
1521
const
1522
  RES_DEFAULT = false; // Windows 95 - Standardwert
1523
begin
1524
  result := RES_DEFAULT;
1525
 
1526
  reg := TRegistry.Create;
1527
  try
1528
    reg.RootKey := HKEY_LOCAL_MACHINE;
1529
 
1530
    // Im Auslieferungszustand von Windows 95 ist dieser Schlüssel nicht vorhanden.
1531
    // Er wird bei der ersten Änderung der Papierkorb-Einstellungen erstellt.
1532
    if reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\BitBucket') then
1533
    begin
1534
      if reg.ValueExists('NukeOnDelete') then
1535
      begin
1536
        // Windows 2000 - Informationen liegen aufgeschlüsselt in der Registry
1537
 
1538
        result := reg.ReadBool('NukeOnDelete');
1539
      end
1540
      else if reg.ValueExists('PurgeInfo') then
1541
      begin
1542
        // Windows 95 - Kodierte Informationen liegen in PurgeInfo
1543
 
1544
        reg.ReadBinaryData('PurgeInfo', purgeInfo, SizeOf(purgeInfo));
1545
        result := (purgeInfo.NukeOnDeleteBits and $8000000) = $8000000; // bit 27
1546
      end;
1547
 
1548
      reg.CloseKey;
1549
    end;
1550
  finally
1551
    reg.Free;
1552
  end;
1553
end;
1554
 
76 daniel-mar 1555
(* TODO:
1556
There are more registry values (found in WinXP):
1557
 
1558
BitBucket\<driveletter>
1559
  VolumeSerialNumber
1560
  IsUnicode
1561
 
1562
*)
1563
 
75 daniel-mar 1564
class function TRecycleBinManager.UsesGlobalSettings: boolean;
1565
var
1566
  reg: TRegistry;
1567
  purgeInfo: TRbWin95PurgeInfo;
1568
const
1569
  RES_DEFAULT = true; // Windows 95 - Standardwert
1570
begin
1571
  result := RES_DEFAULT;
1572
 
1573
  reg := TRegistry.Create;
1574
  try
1575
    reg.RootKey := HKEY_LOCAL_MACHINE;
1576
 
1577
    // Im Auslieferungszustand von Windows 95 ist dieser Schlüssel nicht vorhanden.
1578
    // Er wird bei der ersten Änderung der Papierkorb-Einstellungen erstellt.
1579
    if reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\explorer\BitBucket') then
1580
    begin
1581
      if reg.ValueExists('UseGlobalSettings') then
1582
      begin
1583
        // Windows 2000 - Informationen liegen aufgeschlüsselt in der Registry
1584
 
1585
        result := reg.ReadBool('UseGlobalSettings');
1586
      end
1587
      else if reg.ValueExists('PurgeInfo') then
1588
      begin
1589
        // Windows 95 - Kodierte Informationen liegen in PurgeInfo
1590
 
1591
        reg.ReadBinaryData('PurgeInfo', purgeInfo, SizeOf(purgeInfo));
1592
        result := purgeInfo.bGlobalSettings;
1593
      end;
1594
 
1595
      reg.CloseKey;
1596
    end;
1597
  finally
1598
    reg.Free;
1599
  end;
1600
end;
1601
 
1602
class procedure TRecycleBinManager.ListDrives(list: TObjectList{TRbDrive});
1603
var
1604
  drive: Char;
1605
begin
1606
  for drive := 'A' to 'Z' do
1607
    if RecycleBinPossible(drive) then
1608
      list.Add(TRbDrive.Create(drive));
1609
end;
1610
 
1611
class function TRecycleBinManager.OwnRecyclersEmpty: boolean;
1612
var
1613
  drives: TObjectList;
1614
  i: integer;
1615
begin
1616
  result := true;
1617
 
1618
  drives := TObjectList.Create(true);
1619
  try
1620
    ListDrives(drives);
1621
    for i := 0 to drives.Count - 1 do
1622
    begin
1623
      result := result and TRbDrive(drives.Items[i]).IsEmpty;
1624
      if not result then break;
1625
    end;
1626
  finally
1627
    drives.Free;
1628
  end;
1629
end;
1630
 
1631
class function TRecycleBinManager.OwnRecyclersNumItems: int64;
1632
var
1633
  drives: TObjectList;
1634
  i: integer;
1635
begin
1636
  result := 0;
1637
 
1638
  drives := TObjectList.Create(true);
1639
  try
1640
    ListDrives(drives);
1641
    for i := 0 to drives.Count - 1 do
1642
    begin
1643
      result := result + TRbDrive(drives.Items[i]).GetNumItems;
1644
    end;
1645
  finally
1646
    drives.Free;
1647
  end;
1648
end;
1649
 
1650
class function TRecycleBinManager.OwnRecyclersSize: int64;
1651
var
1652
  drives: TObjectList;
1653
  i: integer;
1654
begin
1655
  result := 0;
1656
 
1657
  drives := TObjectList.Create(true);
1658
  try
1659
    ListDrives(drives);
1660
    for i := 0 to drives.Count - 1 do
1661
    begin
1662
      result := result + TRbDrive(drives.Items[i]).GetSize;
1663
    end;
1664
  finally
1665
    drives.Free;
1666
  end;
1667
end;
1668
 
1669
class function TRecycleBinManager.RecycleBinPossible(Drive: Char): boolean;
1670
var
1671
  typ: Integer;
1672
begin
1673
  // Does the drive exist?
1674
  // see http://www.delphipraxis.net/post2933.html
1675
  result := GetLogicalDrives and (1 shl DriveLetterToDriveNumber(Drive)) <> 0;
1676
  if not result then exit;
1677
 
1678
  // Is it a fixed drive? (Only they can have recycle bins)
1679
  // TODO: is that correct, or can also have other drive types have recyclers?
1680
  typ := GetDriveType(PChar(Drive + ':\'));
1681
  result := typ = DRIVE_FIXED;
1682
end;
1683
 
1684
class function TRecycleBinManager.RecyclerGetCurrentIconString: string;
1685
begin
1686
  if OwnRecyclersEmpty then
1687
    result := RecyclerGetEmptyIconString
1688
  else
1689
    result := RecyclerGetFullIconString;
1690
end;
1691
 
1692
class function TRecycleBinManager.RecyclerGetDefaultIconString: string;
1693
var
1694
  reg: TRegistry;
1695
begin
1696
  // Please note: The "default" icon is not always the icon of the
1697
  // current recycle bin in its current state (full, empty)
1698
  // At Windows 95b, the registry value actually did change every time the
1699
  // recycle bin state did change, but at Windows 2000 I could not see any
1700
  // update, even after reboot. So, the registry value is possible fixed as
1701
  // default = empty on newer OS versions.
1702
 
1703
  reg := TRegistry.Create;
1704
  try
1705
    reg.RootKey := HKEY_CLASSES_ROOT;
1706
    if reg.OpenKeyReadOnly('CLSID\'+GUIDToString(RECYCLER_CLSID)+'\DefaultIcon') then
1707
    begin
1708
      result := reg.ReadString('');
1709
      reg.CloseKey;
1710
    end;
1711
  finally
1712
    reg.Free;
1713
  end;
1714
end;
1715
 
1716
class function TRecycleBinManager.RecyclerGetEmptyIconString: string;
1717
var
1718
  reg: TRegistry;
1719
begin
1720
  reg := TRegistry.Create;
1721
  try
1722
    reg.RootKey := HKEY_CLASSES_ROOT;
1723
    if reg.OpenKeyReadOnly('CLSID\'+GUIDToString(RECYCLER_CLSID)+'\DefaultIcon') then
1724
    begin
1725
      result := reg.ReadString('Empty');
1726
      reg.CloseKey;
1727
    end;
1728
  finally
1729
    reg.Free;
1730
  end;
1731
end;
1732
 
1733
class function TRecycleBinManager.RecyclerGetFullIconString: string;
1734
var
1735
  reg: TRegistry;
1736
begin
1737
  reg := TRegistry.Create;
1738
  try
1739
    reg.RootKey := HKEY_CLASSES_ROOT;
1740
    if reg.OpenKeyReadOnly('CLSID\'+GUIDToString(RECYCLER_CLSID)+'\DefaultIcon') then
1741
    begin
1742
      result := reg.ReadString('Full');
1743
      reg.CloseKey;
1744
    end;
1745
  finally
1746
    reg.Free;
1747
  end;
1748
end;
1749
 
1750
class function TRecycleBinManager.RecyclerGetInfoTip: string;
1751
var
1752
  reg: TRegistry;
1753
begin
1754
  // Not available in some older versions of Windows
1755
 
1756
  reg := TRegistry.Create;
1757
  try
1758
    reg.RootKey := HKEY_CLASSES_ROOT;
1759
    if reg.OpenKeyReadOnly('CLSID\'+GUIDToString(RECYCLER_CLSID)) then
1760
    begin
1761
      result := reg.ReadString('InfoTip');
1762
      result := DecodeReferenceString(result);
1763
 
1764
      reg.CloseKey;
1765
    end;
1766
  finally
1767
    reg.Free;
1768
  end;
1769
end;
1770
 
1771
class function TRecycleBinManager.RecyclerGetIntroText: string;
1772
var
1773
  reg: TRegistry;
1774
begin
1775
  // Not available in some older versions of Windows
1776
 
1777
  reg := TRegistry.Create;
1778
  try
1779
    reg.RootKey := HKEY_CLASSES_ROOT;
1780
    if reg.OpenKeyReadOnly('CLSID\'+GUIDToString(RECYCLER_CLSID)) then
1781
    begin
1782
      result := reg.ReadString('IntroText');
1783
      result := DecodeReferenceString(result);
1784
 
1785
      reg.CloseKey;
1786
    end;
1787
  finally
1788
    reg.Free;
1789
  end;
1790
end;
1791
 
1792
class function TRecycleBinManager.RecyclerGetName: string;
1793
var
1794
  reg: TRegistry;
1795
begin
1796
  // Windows 95b:
1797
  // Change of CLSID\{645FF040-5081-101B-9F08-00AA002F954E} will change the desktop name of the recycle bin.
1798
 
1799
  // Windows 2000: If LocalizedString is available, the 3rd argument will be parsed
1800
  // (if the third argument will removed, it will be read out from the DLL resource string automatically)
1801
 
1802
  reg := TRegistry.Create;
1803
  try
1804
    reg.RootKey := HKEY_CLASSES_ROOT;
1805
    if reg.OpenKeyReadOnly('CLSID\'+GUIDToString(RECYCLER_CLSID)) then
1806
    begin
1807
      if reg.ValueExists('LocalizedString') then
1808
      begin
1809
        result := reg.ReadString('LocalizedString');
1810
        result := DecodeReferenceString(result);
1811
      end
1812
      else
1813
      begin
1814
        result := reg.ReadString('');
1815
      end;
1816
 
1817
      reg.CloseKey;
1818
    end;
1819
  finally
1820
    reg.Free;
1821
  end;
1822
end;
1823
 
1824
class function TRecycleBinManager.RecyclerEmptyEventGetName: string;
1825
var
1826
  reg: TRegistry;
1827
begin
1828
  reg := TRegistry.Create;
1829
  try
1830
    reg.RootKey := HKEY_CURRENT_USER;
1831
    if reg.OpenKeyReadOnly('AppEvents\EventLabels\EmptyRecycleBin') then
1832
    begin
1833
      result := reg.ReadString('');
1834
      reg.CloseKey;
1835
    end;
1836
  finally
1837
    reg.Free;
1838
  end;
1839
end;
1840
 
1841
class function TRecycleBinManager.RecyclerEmptyEventGetCurrentSound: string;
1842
begin
1843
  result := RecyclerEmptyEventGetSound('.Current');
1844
end;
1845
 
1846
class function TRecycleBinManager.RecyclerEmptyEventGetDefaultSound: string;
1847
begin
1848
  result := RecyclerEmptyEventGetSound('.Default');
1849
end;
1850
 
1851
class procedure TRecycleBinManager.RecyclerEmptyEventGetSoundCategories(AStringList: TStringList);
1852
var
1853
  reg: TRegistry;
1854
begin
1855
  reg := TRegistry.Create;
1856
  try
1857
    reg.RootKey := HKEY_CURRENT_USER;
1858
    if reg.OpenKeyReadOnly('AppEvents\Schemes\Apps\Explorer\EmptyRecycleBin') then
1859
    begin
1860
      reg.GetKeyNames(AStringList);
1861
      reg.CloseKey;
1862
    end;
1863
  finally
1864
    reg.Free;
1865
  end;
1866
end;
1867
 
1868
class function TRecycleBinManager.RecyclerEmptyEventGetSound(ACategory: string): string;
1869
var
1870
  reg: TRegistry;
1871
resourcestring
1872
  LNG_SND_EVENT_CAT_ERROR = 'The category "%s" is not available for the notification event "%s".';
1873
begin
1874
  // Outputs an filename or empty string for no sound defined.
1875
 
1876
  reg := TRegistry.Create;
1877
  try
1878
    reg.RootKey := HKEY_CURRENT_USER;
1879
    if reg.OpenKeyReadOnly('AppEvents\Schemes\Apps\Explorer\EmptyRecycleBin') then
1880
    begin
1881
      if reg.OpenKeyReadOnly(ACategory) then
1882
      begin
1883
        result := reg.ReadString('');
1884
        reg.CloseKey;
1885
      end
1886
      else
1887
        raise EEventCategoryNotDefined.CreateFmt(LNG_SND_EVENT_CAT_ERROR, [ACategory, 'EmptyRecycleBin']);
1888
      reg.CloseKey;
1889
    end;
1890
  finally
1891
    reg.Free;
1892
  end;
1893
end;
1894
 
1895
class function TRecycleBinManager.RecyclerQueryFunctionAvailable: boolean;
1896
var
1897
  RBHandle: THandle;
1898
  SHQueryRecycleBin: TSHQueryRecycleBin;
1899
begin
1900
  // Windows 95 without Internet Explorer 4 has no SHQueryRecycleBinA.
1901
  RBHandle := LoadLibrary(shell32);
1902
  try
1903
    if RBHandle <> 0 then
1904
    begin
1905
      SHQueryRecycleBin := GetProcAddress(RBHandle, C_SHQueryRecycleBin);
1906
      if not Assigned(@SHQueryRecycleBin) then
1907
      begin
1908
        FreeLibrary(RBHandle);
1909
        RBHandle := 0;
1910
      end;
1911
    end;
1912
 
1913
    result := RBHandle <> 0;
1914
  finally
1915
    if RBHandle <> 0 then FreeLibrary(RBHandle);
1916
  end;
1917
end;
1918
 
1919
class function TRecycleBinManager.RecyclerAddFileOrFolder(FileOrFolder: string; confirmation: boolean=false): boolean;
1920
var
1921
  Operation: TSHFileOpStruct;
1922
begin
1923
  // Template: http://www.dsdt.info/tipps/?id=116
1924
  with Operation do
1925
  begin
1926
    Wnd := hInstance; // OK?
1927
    wFunc := FO_DELETE;
1928
    pFrom := PChar(FileOrFolder + #0);
1929
    pTo := nil;
1930
    fFlags := FOF_ALLOWUNDO;
1931
    if not confirmation then fFlags := fFlags or FOF_NOCONFIRMATION;
1932
  end;
1933
  Result := SHFileOperation(Operation) = 0;
1934
end;
1935
 
1936
class function TRecycleBinManager.RecyclerGroupPolicyNoRecycleFiles: GPOLICYBOOL;
1937
var
1938
  reg: TRegistry;
1939
begin
1940
  result := gpUndefined;
1941
 
1942
  reg := TRegistry.Create;
1943
  try
1944
    // If a value is set in HKEY_LOCAL_MACHINE, it will be prefered,
1945
    // even if gpedit.msc shows "Not configured"!
1946
    {$IFDEF GroupPolicyAcceptHKLMTrick}
1947
    reg.RootKey := HKEY_LOCAL_MACHINE;
1948
    if reg.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer') then
1949
    begin
1950
      if reg.ValueExists('NoRecycleFiles') then
1951
      begin
1952
        if reg.ReadBool('NoRecycleFiles') then
1953
          result := gpEnabled
1954
        else
1955
          result := gpDisabled;
1956
        Exit;
1957
      end;
1958
      reg.CloseKey;
1959
    end;
1960
    {$ENDIF}
1961
 
1962
    reg.RootKey := HKEY_CURRENT_USER;
1963
    if reg.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer') then
1964
    begin
1965
      if reg.ValueExists('NoRecycleFiles') then
1966
      begin
1967
        if reg.ReadBool('NoRecycleFiles') then
1968
          result := gpEnabled
1969
        else
1970
          result := gpDisabled;
1971
      end;
1972
      reg.CloseKey;
1973
    end;
1974
  finally
1975
    reg.Free;
1976
  end;
1977
end;
1978
 
1979
class function TRecycleBinManager.RecyclerGroupPolicyConfirmFileDelete: GPOLICYBOOL;
1980
var
1981
  reg: TRegistry;
1982
begin
1983
  result := gpUndefined;
1984
  reg := TRegistry.Create;
1985
  try
1986
    // If a value is set in HKEY_LOCAL_MACHINE, it will be prefered,
1987
    // even if gpedit.msc shows "Not configured"!
1988
    {$IFDEF GroupPolicyAcceptHKLMTrick}
1989
    reg.RootKey := HKEY_LOCAL_MACHINE;
1990
    if reg.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer') then
1991
    begin
1992
      if reg.ValueExists('ConfirmFileDelete') then
1993
      begin
1994
        if reg.ReadBool('ConfirmFileDelete') then
1995
          result := gpEnabled
1996
        else
1997
          result := gpDisabled;
1998
        Exit;
1999
      end;
2000
      reg.CloseKey;
2001
    end;
2002
    {$ENDIF}
2003
 
2004
    reg.RootKey := HKEY_CURRENT_USER;
2005
    if reg.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer') then
2006
    begin
2007
      if reg.ValueExists('ConfirmFileDelete') then
2008
      begin
2009
        if reg.ReadBool('ConfirmFileDelete') then
2010
          result := gpEnabled
2011
        else
2012
          result := gpDisabled;
2013
      end;
2014
      reg.CloseKey;
2015
    end;
2016
  finally
2017
    reg.Free;
2018
  end;
2019
end;
2020
 
2021
class function TRecycleBinManager.RecyclerGroupPolicyRecycleBinSize: integer;
2022
var
2023
  reg: TRegistry;
2024
begin
2025
  result := -1;
2026
  reg := TRegistry.Create;
2027
  try
2028
    // If a value is set in HKEY_LOCAL_MACHINE, it will be prefered,
2029
    // even if gpedit.msc shows "Not configured"!
2030
    {$IFDEF GroupPolicyAcceptHKLMTrick}
2031
    reg.RootKey := HKEY_LOCAL_MACHINE;
2032
    if reg.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer') then
2033
    begin
2034
      if reg.ValueExists('RecycleBinSize') then
2035
      begin
2036
        result := reg.ReadInteger('RecycleBinSize');
2037
        Exit;
2038
      end;
2039
      reg.CloseKey;
2040
    end;
2041
    {$ENDIF}
2042
 
2043
    reg.RootKey := HKEY_CURRENT_USER;
2044
    if reg.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer') then
2045
    begin
2046
      if reg.ValueExists('RecycleBinSize') then
2047
      begin
2048
        result := reg.ReadInteger('RecycleBinSize');
2049
      end;
2050
      reg.CloseKey;
2051
    end;
2052
  finally
2053
    reg.Free;
2054
  end;
2055
end;
2056
 
2057
class function TRecycleBinManager.RecyclerConfirmationDialogEnabled: boolean;
2058
var
2059
  gp: GPOLICYBOOL;
2060
begin
2061
  gp := RecyclerGroupPolicyConfirmFileDelete;
2062
  if gp <> gpUndefined then
2063
  begin
2064
    result := gp = gpEnabled;
2065
  end
2066
  else
2067
  begin
2068
    result := RecyclerShellStateConfirmationDialogEnabled;
2069
  end;
2070
end;
2071
 
2072
class function TRecycleBinManager.RecyclerShellStateConfirmationDialogEnabled: boolean;
2073
var
2074
  lpss: SHELLSTATE;
2075
  bNoConfirmRecycle: boolean;
2076
 
2077
  PSHGetSettings: TSHGetSettings;
2078
  RBHandle: THandle;
2079
 
2080
  reg: TRegistry;
2081
  rbuf: array[0..255] of byte;
2082
begin
2083
  PSHGetSettings := nil;
2084
  result := false; // Avoid warning message
2085
 
2086
  RBHandle := LoadLibrary(shell32);
2087
  try
2088
    if RBHandle <> 0 then
2089
    begin
2090
      PSHGetSettings := GetProcAddress(RBHandle, C_SHGetSettings);
2091
      if not Assigned(@PSHGetSettings) then
2092
      begin
2093
        FreeLibrary(RBHandle);
2094
        RBHandle := 0;
2095
      end;
2096
    end;
2097
 
2098
    if (RBHandle <> 0) and Assigned(PSHGetSettings) then
2099
    begin
2100
      ZeroMemory(@lpss, SizeOf(lpss));
2101
      PSHGetSettings(lpss, SSF_NOCONFIRMRECYCLE);
2102
      bNoConfirmRecycle := (lpss.Flags1 and 4) = 4; // fNoConfirmRecycle
2103
 
2104
      result := not bNoConfirmRecycle;
2105
    end
2106
    else
2107
    begin
2108
      reg := TRegistry.Create;
2109
      try
2110
        // API function call failed. Probably because Windows is too old.
2111
        // Try to read out from registry.
2112
        // The 3rd bit of the 5th byte of "ShellState" is the value
2113
        // of "fNoConfirmRecycle".
2114
 
2115
        reg.RootKey := HKEY_CURRENT_USER;
2116
        if reg.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Explorer') then
2117
        begin
2118
          ZeroMemory(@rbuf, SizeOf(rbuf));
2119
          reg.ReadBinaryData('ShellState', rbuf, SizeOf(rbuf));
2120
 
2121
          // Lese 3tes Bit vom 5ten Byte
2122
          bNoConfirmRecycle := ((rbuf[4] and 4) = 4);
2123
          result := not bNoConfirmRecycle;
2124
 
2125
          reg.CloseKey;
2126
        end
2127
        else
2128
        begin
2129
          raise EAPICallError.CreateFmt(LNG_API_CALL_ERROR, [Format(LNG_NOT_CALLABLE, [C_SHGetSettings])]);
2130
        end;
2131
      finally
2132
        reg.Free;
2133
      end;
2134
    end;
2135
  finally
2136
    if RBHandle <> 0 then FreeLibrary(RBHandle);
2137
  end;
2138
end;
2139
 
2140
class procedure TRecycleBinManager.RecyclerConfirmationDialogSetEnabled(NewSetting: boolean);
2141
var
2142
  lpss: SHELLSTATE;
2143
 
2144
  PSHGetSetSettings: TSHGetSetSettings;
2145
  RBHandle: THandle;
2146
 
2147
  reg: TRegistry;
2148
  rbuf: array[0..255] of byte;
2149
 
2150
  dwResult: DWORD;
2151
begin
2152
  PSHGetSetSettings := nil;
2153
 
2154
  RBHandle := LoadLibrary(shell32);
2155
  try
2156
    if RBHandle <> 0 then
2157
    begin
2158
      PSHGetSetSettings := GetProcAddress(RBHandle, C_SHGetSetSettings);
2159
      if not Assigned(@PSHGetSetSettings) then
2160
      begin
2161
        FreeLibrary(RBHandle);
2162
        RBHandle := 0;
2163
      end;
2164
    end;
2165
 
2166
    if (RBHandle <> 0) and Assigned(PSHGetSetSettings) then
2167
    begin
2168
      ZeroMemory(@lpss, SizeOf(lpss));
2169
 
2170
      PSHGetSetSettings(lpss, SSF_NOCONFIRMRECYCLE, false); // Get
2171
 
2172
      // Set 3rd bit equal to NewSetting
2173
      if NewSetting then
2174
        lpss.Flags1 := lpss.Flags1 or  $00000004
2175
      else
2176
        lpss.Flags1 := lpss.Flags1 and $FFFFFFFB;
2177
 
2178
      PSHGetSetSettings(lpss, SSF_NOCONFIRMRECYCLE, true); // Set
2179
 
2180
      SendMessageTimeout (
2181
        HWND_BROADCAST, WM_SETTINGCHANGE,
2182
        0, lParam (pChar ('ShellState')),
2183
        SMTO_ABORTIFHUNG, 5000, dwResult
2184
      );
2185
    end
2186
    else
2187
    begin
2188
      reg := TRegistry.Create;
2189
      try
2190
        // API function call failed. Probably because Windows is too old.
2191
        // Try to read out from registry.
2192
        // The 3rd bit of the 5th byte of "ShellState" is the value
2193
        // of "fNoConfirmRecycle".
2194
 
2195
        reg.RootKey := HKEY_CURRENT_USER;
2196
        if reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer', false) then
2197
        begin
2198
          ZeroMemory(@rbuf, SizeOf(rbuf));
2199
 
2200
          reg.ReadBinaryData('ShellState', rbuf, SizeOf(rbuf)); // Get
2201
 
2202
          // Set 3rd bit equal to NewSetting
2203
          if NewSetting then
2204
            rbuf[4] := rbuf[4] or  $04
2205
          else
2206
            rbuf[4] := rbuf[4] and $FB;
2207
 
2208
          reg.WriteBinaryData('ShellState', rbuf, SizeOf(rbuf)); // Set
2209
 
2210
          SendMessageTimeout (
2211
            HWND_BROADCAST, WM_SETTINGCHANGE,
2212
            0, lParam (pChar ('ShellState')),
2213
            SMTO_ABORTIFHUNG, 5000, dwResult
2214
          );
2215
 
2216
          reg.CloseKey;
2217
        end
2218
        else
2219
        begin
2220
          raise EAPICallError.CreateFmt(LNG_API_CALL_ERROR, [Format(LNG_NOT_CALLABLE, [C_SHGetSetSettings])]);
2221
        end;
2222
      finally
2223
        reg.Free;
2224
      end;
2225
    end;
2226
  finally
2227
    if RBHandle <> 0 then FreeLibrary(RBHandle);
2228
  end;
2229
end;
2230
 
2231
{ TRbRecycleBinItem }
2232
 
2233
function TRbRecycleBinItem.GetSource: string;
2234
begin
2235
  {$IFDEF UNICODE}
2236
  result := SourceUnicode;
2237
  {$ELSE}
2238
  result := SourceAnsi;
2239
  {$ENDIF}
2240
end;
2241
 
2242
end.