Subversion Repositories recyclebinunit

////////////////////////////////////////////////////////////////////////////////////

// RECYCLE-BIN-FUNCTIONS BY DANIEL MARSCHALL                                      //

// E-MAIL: info@daniel-marschall.de                                               //

// WEB:    www.daniel-marschall.de                                                //

////////////////////////////////////////////////////////////////////////////////////

// Revision: 28 SEP 2015                                                          //

// This unit is freeware, but please link to my website if you are using it!      //

////////////////////////////////////////////////////////////////////////////////////

// Successful tested with:                                                        //

// Windows 95b (without IE4 Shell Extensions)                                     //

// Windows 95b (with IE4 Shell Extensions)                                        //

// Windows 98-SE                                                                  //

// Windows NT4 SP6                                                                //

// Windows XP-SP3                                                                 //

// Windows 2000-SP4                                                               //

// Windows 2003 Server EE SP1                                                     //

// Windows Vista                                                                  //

// Windows 7                                                                      //

// Windows 10                                                                     //

////////////////////////////////////////////////////////////////////////////////////

//                                                                                //

//  Needs Delphi 4 or higher. If you are using Delphi 4 or 5, you can not use the //

//  RecyclerGetDateTime() functions, because the unit "DateUtils" is missing.     //

//  Warning! This is a platform unit.                                             //

//                                                                                //

//  To do! Can you help?                                                          //

//    - Win7 : Drive GUIDs                                                        //

//    - Win7 : Absolute vs. Relative size limitations                             //

//    - WideString-Support (input/output)                                         //

//    - Always do EOF before reading anything?                                    //

//    - Is it possible to identify a Vista-file that is not named $Ixxxxxx.ext?   //

//    - RecyclerGetInfofiles() check additionally for removable device?           //

//      RecyclerIsValid() is false.                                               //

//    - Make it possible to empty the recycle bin of one specific drive!          //

//                                                                                //

//  Unknown! Do you know the answer?                                              //

//    - How does Windows 9x/NT manage the daylight saving time (if it does)?      //

//    - How does Windows Vista react to a RECYCLER\ folder on a NTFS device?      //

//    - How does Windows Vista react to a RECYCLED\ folder on a FAT device?       //

//                                                                                //

//  Thanks to all these who have helped me solving coding problems.               //

//  Thanks to SEBA for sending in the Windows Vista trash structure files.        //

//  Thanks to OMATA for testing the unit with Delphi 4.                           //

//  Thanks to DEITYSOU for making a bugfix of DriveExists()                       //

//                                                                                //

////////////////////////////////////////////////////////////////////////////////////

(*

== TODO LISTE ==

- Wichtig! Windows XP: InfoTip, IntroText und LocalizedString sind Resourcenangaben und müssen ausgelesen werden!

- Testen: Wie reagiert Windows, wenn Bitbucket\C existiert, aber kein Wert 'Percent' hat? Mit der Standardeinstellung?

- Bug: Windows 2000 bei bestehenden Windows 95 Partition: Recycler Filename ist dann Recycled und nicht Recycler!

- bug? w95 recycled file hat immer selben löschzeitpunkt und größe? war die nicht verschieden?

- beachtet? bei leerem papierkorb auf fat ist weder info noch info2 vorhanden?

- testen: auch möglich, einen vista papierkorb offline öffnen?

- Problem: bei win95(ohne ie4) und win2000 gleichzeitiger installation: es existiert info UND info2!!!

- Implement SETTER functions to every kind of configuration thing. (percentage etc)

- Registry CURRENT_USER: Funktionen auch für fremde Benutzer zur Verfügung stellen?

- Es sollte möglich sein, dass ein Laufwerk mehr als 1 Recycler beinhaltet -- behandeln

=== Future Ideas ===

- Demoapplikation: Dateien statt Text als Explorer-Like (TListView)?

- Einzelne Elemente oder alle wiederherstellen oder löschen

- Konfiguration für Laufwerke ändern etc

- IconString -> TIcon Convertion functions

- platzreservierung in mb-angabe berechnen

- I don't know if there exists any API function which checks the state at any internal way.

- copy/move files from recyclebin

*)

// TODO: Also include BC++ Versions

{$IFNDEF BCB}

{$DEFINE DEL1UP}

{$IFNDEF VER80}

{$DEFINE DEL2UP}

{$IFNDEF VER90}

{$DEFINE DEL3UP}

{$IFNDEF VER100}

{$DEFINE DEL4UP}

{$IFNDEF VER120}

{$DEFINE DEL5UP}

{$IFNDEF VER130}

{$DEFINE DEL6UP}

{$IFNDEF VER140}

{$DEFINE DEL7UP}

{$ENDIF}

{$ENDIF}

{$ENDIF}

{$ENDIF}

{$ENDIF}

{$ENDIF}

{$ENDIF}

{$IFDEF DEL7UP}

{$WARN UNSAFE_TYPE OFF}

{$WARN UNSAFE_CODE OFF}

{$WARN UNSAFE_CAST OFF}

{$ENDIF}

{$IFDEF DEL6UP}

unit RecyclerFunctions platform;

{$ELSE}

unit RecyclerFunctions;

{$ENDIF}

// Configuration

// If enabled, all functions with parameter "InfofileOrRecycleFolder" will

// also accept files which are not the indexfile (then, a INFO2 or INFO file

// will be searched in this directory).

{.$DEFINE allow_all_filenames}

interface

uses

  Windows, SysUtils, Classes, {$IFDEF DEL6UP}DateUtils,{$ENDIF}

  ShellApi{$IFNDEF DEL6UP}, FileCtrl{$ENDIF}, Registry,

  Messages, BitOps;

type

  EUnknownState = class(Exception);

  EEventCategoryNotDefined = class(Exception);

  EAPICallError = class(Exception);

  PSHQueryRBInfo = ^TSHQueryRBInfo;

  TSHQueryRBInfo = packed record

    cbSize      : dword;

    i64Size     : int64;

    i64NumItems : int64;

  end;

  GPOLICYBOOL = (gpUndefined, gpEnabled, gpDisabled);

const

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

{$IFDEF DEL6UP}

function RecyclerGetDateTime(drive: char; fileid: string): tdatetime; overload;

function RecyclerGetDateTime(drive: char; UserSID: string; fileid: string): tdatetime; overload;

function RecyclerGetDateTime(InfofileOrRecycleFolder: string): tdatetime; overload;

function RecyclerGetDateTime(InfofileOrRecycleFolder: string; id: string): tdatetime; overload;

{$ENDIF}

function RecyclerGetSourceUnicode(drive: char; fileid: string): WideString; overload;

function RecyclerGetSourceUnicode(drive: char; UserSID: string; fileid: string): WideString; overload;

function RecyclerGetSourceUnicode(InfofileOrRecycleFolder: string): WideString; overload;

function RecyclerGetSourceUnicode(InfofileOrRecycleFolder: string; id: string): WideString; overload;

function RecyclerGetSource(drive: char; fileid: string): string; overload;

function RecyclerGetSource(drive: char; UserSID: string; fileid: string): string; overload;

function RecyclerGetSource(InfofileOrRecycleFolder: string): string; overload;

function RecyclerGetSource(InfofileOrRecycleFolder: string; id: string): string; overload;

procedure RecyclerListIndexes(drive: char; result: TStringList); overload;

procedure RecyclerListIndexes(drive: char; UserSID: string; result: TStringList); overload;

procedure RecyclerListIndexes(InfofileOrRecycleFolder: string; result: TStringList); overload;

function RecyclerGetSourceDrive(drive: char; fileid: string): char; overload;

function RecyclerGetSourceDrive(drive: char; UserSID: string; fileid: string): char; overload;

function RecyclerGetSourceDrive(InfofileOrRecycleFolder: string): char; overload;

function RecyclerGetSourceDrive(InfofileOrRecycleFolder: string; id: string): char; overload;

function RecyclerOriginalSize(drive: char; fileid: string): integer; overload;

function RecyclerOriginalSize(drive: char; UserSID: string; fileid: string): integer; overload;

function RecyclerOriginalSize(InfofileOrRecycleFolder: string): integer; overload;

function RecyclerOriginalSize(InfofileOrRecycleFolder: string; id: string): integer; overload;

function RecyclerIsValid(drive: char): boolean; overload;

function RecyclerIsValid(drive: char; UserSID: string): boolean; overload;

function RecyclerIsValid(InfofileOrRecycleFolder: string): boolean; overload;

function RecyclerCurrentFilename(drive: char; fileid: string): string; overload;

function RecyclerCurrentFilename(drive: char; UserSID: string; fileid: string): string; overload;

function RecyclerCurrentFilename(InfofileOrRecycleFolder: string): string; overload;

function RecyclerCurrentFilename(InfofileOrRecycleFolder: string; id: string): string; overload;

function RecyclerGetPath(drive: char; UserSID: string; IncludeInfofile: boolean; fileid: string): string; overload;

function RecyclerGetPath(drive: char; UserSID: string; IncludeInfofile: boolean): string; overload;

function RecyclerGetPath(drive: char; IncludeInfofile: boolean): string; overload;

function RecyclerGetPath(drive: char; UserSID: string): string; overload;

function RecyclerGetPath(drive: char): string; overload;

procedure RecyclerGetInfofiles(drive: char; UserSID: string; IncludeInfofile: boolean; fileid: string; result: TStringList); overload;

procedure RecyclerGetInfofiles(drive: char; UserSID: string; IncludeInfofile: boolean; result: TStringList); overload;

procedure RecyclerGetInfofiles(drive: char; IncludeInfofile: boolean; result: TStringList); overload;

procedure RecyclerGetInfofiles(drive: char; UserSID: string; result: TStringList); overload;

procedure RecyclerGetInfofiles(drive: char; result: TStringList); overload;

function RecyclerCurrentFilenameAndPath(drive: char; UserSID: string; fileid: string): string; overload;

function RecyclerCurrentFilenameAndPath(drive: char; fileid: string): string; overload;

function RecyclerCurrentFilenameAndPath(InfofileOrRecycleFolder: string; id: string): string; overload;

function RecyclerRemoveItem(drive: char; UserSID: string; fileid: string): boolean; overload;

function RecyclerRemoveItem(drive: char; fileid: string): boolean; overload;

function RecyclerRemoveItem(InfofileOrRecycleFolder: string; id: string): boolean; overload;

procedure RecyclerGetAllRecyclerDrives(result: TStringList);

function RecyclerEmptyRecycleBin(flags: cardinal): boolean; overload;

function RecyclerEmptyRecycleBin(sound, progress, confirmation: boolean): boolean; overload;

function RecyclerAddFileOrFolder(FileOrFolder: string; confirmation: boolean): boolean; overload;

function RecyclerAddFileOrFolder(FileOrFolder: string): boolean; overload;

function RecyclerConfirmationDialogEnabled: boolean;

function RecyclerShellStateConfirmationDialogEnabled: boolean;

procedure RecyclerConfirmationDialogSetEnabled(NewSetting: boolean);

function RecyclerGetCurrentIconString: string;

function RecyclerGetDefaultIconString: string;

function RecyclerGetEmptyIconString: string;

function RecyclerGetFullIconString: string;

function RecyclerGetName: string;

function RecyclerGetInfoTip: string;

function RecyclerGetIntroText: string;

function RecyclerEmptyEventGetName: string;

function RecyclerEmptyEventGetCurrentSound: string;

function RecyclerEmptyEventGetDefaultSound: string;

procedure RecyclerEmptyEventGetSoundCategories(AStringList: TStringList);

function RecyclerEmptyEventGetSound(ACategory: string): string;

function RecyclerGlobalGetPercentUsage: integer;

function RecyclerSpecificGetPercentUsage(Drive: Char): integer;

function RecyclerGetPercentUsageAutoDeterminate(Drive: Char): integer;

function RecyclerGlobalIsNukeOnDelete: boolean;

function RecyclerSpecificIsNukeOnDelete(Drive: Char): boolean;

function RecyclerIsNukeOnDeleteAutoDeterminate(Drive: Char): boolean;

function RecyclerHasGlobalSettings: boolean;

function RecyclerIsEmpty: boolean; overload;

function RecyclerIsEmpty(Drive: Char): boolean; overload;

function RecyclerGetNumItems: int64; overload;

function RecyclerGetNumItems(Drive: Char): int64; overload;

function RecyclerGetSize: int64; overload;

function RecyclerGetSize(Drive: Char): int64; overload;

function RecyclerGetAPIInfo(Drive: Char): TSHQueryRBInfo; overload;

function RecyclerGetAPIInfo(Path: String): TSHQueryRBInfo; overload;

function RecyclerGetCLSID: string;

// 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

function RecyclerQueryFunctionAvailable: boolean;

function RecyclerGroupPolicyNoRecycleFiles: GPOLICYBOOL;

function RecyclerGroupPolicyConfirmFileDelete: GPOLICYBOOL;

function RecyclerGroupPolicyRecycleBinSize: integer;

function GPBoolToString(value: GPOLICYBOOL): String;

function RecyclerIsPossible(Drive: Char): boolean;

function RecyclerLibraryVersion: string;

implementation

type

  SHELLSTATE = record

    Flags1: DWORD;

(*

    BOOL fShowAllObjects : 1;

    BOOL fShowExtensions : 1;

    BOOL fNoConfirmRecycle : 1;

    BOOL fShowSysFiles : 1;

    BOOL fShowCompColor : 1;

    BOOL fDoubleClickInWebView : 1;

    BOOL fDesktopHTML : 1;

    BOOL fWin95Classic : 1;

    BOOL fDontPrettyPath : 1;

    BOOL fShowAttribCol : 1; // No longer used, dead bit

    BOOL fMapNetDrvBtn : 1;

    BOOL fShowInfoTip : 1;

    BOOL fHideIcons : 1;

    BOOL fWebView : 1;

    BOOL fFilter : 1;

    BOOL fShowSuperHidden : 1;

    BOOL fNoNetCrawling : 1;

*)

    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;

(*

    BOOL fSepProcess: 1;

    // new for Whistler.

    BOOL fStartPanelOn: 1;       //Indicates if the Whistler StartPanel mode is ON or OFF.

    BOOL fShowStartPage: 1;      //Indicates if the Whistler StartPage on desktop is ON or OFF.

    UINT fSpareFlags : 13;

*)

  end;

  LPSHELLSTATE = ^SHELLSTATE;

const

  {$IFDEF MSWINDOWS}

    shell32  = 'shell32.dll';

    advapi32 = 'advapi32.dll';

  {$ENDIF}

  {$IFDEF LINUX}

    shell32  = 'libshell32.borland.so';

    advapi32 = 'libwine.borland.so';

  {$ENDIF}

  // 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;

// **********************************************************

// COMPATIBILITY FUNCTIONS

// **********************************************************

{$IFNDEF DEL5UP}

function IncludeTrailingBackslash(str: string): string;

begin

  if Copy(str, length(str), 1) = '\' then    // TODO? Gibt es PathDelim in Delphi 4?

    Result := str

  else

    Result := str + '\';

end;

{$ENDIF}

// **********************************************************

// INTERNALLY USED FUNCTIONS

// **********************************************************

resourcestring

  LNG_UNEXPECTED_STATE = 'Cannot determinate state of "%s" because of an unknown value in the configuration of your operation system. Please contact the developer of the Recycler Bin Unit and help improving the determination methods!';

  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';

function _DeleteDirectory(const Name: string): boolean;

var

  F: TSearchRec;

begin

  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;

end;

function _FileSize(FileName: string): int64;

var

  fs: TFileStream;

begin

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

  try

    result := fs.size;

  finally

    fs.free;

  end;

end;

function _DriveNum(Drive: Char): Byte;

// a->0, ..., z->25

var

  tmp: string;

begin

  tmp := LowerCase(Drive);

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

end;

function _registryReadDump(AReg: TRegistry; AName: string): string;

const

  // Win2000 RegEdit has set the max input length of a REG_BINARY to $3FFF.

  // Probably its the longest possible binary string and not just a GUI limit.

  BufMax = $3FFF;

var

  buf: array[0..BufMax] of byte;

  i: integer;

  realsize: integer;

begin

  realsize := AReg.ReadBinaryData(AName, buf, SizeOf(buf));

  for i := 0 to realsize-1 do

  begin

    result := result + chr(buf[i]);

  end;

end;

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

const

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

  MAX_BUF = 4097; // OK?

var

  hLib: THandle;

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

begin

  hLib := LoadLibrary(PChar(filename));

  try

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

    result := buf;

  finally

    FreeLibrary(hLib);

  end;

end;

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

function _ExpandEnvStr(const szInput: string): string;

const

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

begin

  SetLength(Result,MAXSIZE);

  SetLength(Result,ExpandEnvironmentStrings(pchar(szInput),

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

end;

// Beispiele

// Papierkorb                                                 -- Windows 95

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

function _DecodeReferenceString(s: string): string;

var

  dll, id, lang, cache: string;

  sl, sl2: tstringlist;

begin

  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;

end;

function _readInt8(const Stream: TStream): byte;

var

  I: integer;

begin

  i := 0;

  Stream.ReadBuffer(i, 1);

  Result := i;

end;

function _readInt32(const Stream: TStream): Longword;

var

  I: integer;

begin

  i := 0;

  Stream.ReadBuffer(i, 4);

  Result := i;

end;

function _readInt64(const Stream: TStream): int64;

var

  I: int64;

begin

  i := 0;

  Stream.ReadBuffer(i, 8);

  Result := i;

end;

function _readChar(const Stream: TStream): char;

var

  C: Char;

begin

  C := #0;

  Stream.ReadBuffer(C, 1);

  Result := C;

end;

function _readNullTerminatedString(const Stream: TStream): String;

var

  S: String;

  C: Char;

begin

  S := '';

  repeat

    Stream.ReadBuffer(C, 1);

    if (C <> #0) then

      S := S + C;

  until C = #0;

  Result := S;

end;

// http://www.delphipraxis.net/post761928.html#761928

function _readNullTerminatedWideString(const Stream: TStream): WideString;

var

  S: WideString;

  WC: WideChar;

begin

  S := '';

  repeat

    Stream.ReadBuffer(WC, 2);

    if (WC <> #0) then

      S := S + WC;

  until WC = #0;

  Result := S;

end;

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

function _nowUTC: TDateTime;

var

  SystemTime: TSystemTime;

begin

  GetSystemTime(SystemTime);

  with SystemTime do

  begin

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

              EncodeTime(wHour, wMinute, wSecond, wMilliseconds);

  end;

end;

{$IFDEF DEL6UP}

function _getGMTDifference(): extended;

begin

  result := - (datetimetounix(_nowUTC())-datetimetounix(Now())) / 3600;

end;

function _fileTimeToDateTime(FileTime: int64): TDateTime;

begin

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

  // 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(FileTime div 10000000 - 11644473600 + round(_getGMTDifference() * 3600));

end;

{$ENDIF}

// http://www.delphipraxis.net/post471470.html

function _getAccountSid(const Server, User: WideString; var Sid: PSID): DWORD;

var

  dwDomainSize, dwSidSize: DWord;

  R: LongBool;

  wDomain: WideString;

  Use: DWord;

begin

  Result := 0;

  SetLastError(0);

  dwSidSize := 0;

  dwDomainSize := 0;

  R := LookupAccountNameW(PWideChar(Server), PWideChar(User), nil, dwSidSize,

       nil, dwDomainSize, Use);

  if (not R) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then

  begin

    SetLength(wDomain, dwDomainSize);

    Sid := GetMemory(dwSidSize);

    R := LookupAccountNameW(PWideChar(Server), PWideChar(User), Sid,

         dwSidSize, PWideChar(wDomain), dwDomainSize, Use);

    if not R then

    begin

      FreeMemory(Sid);

      Sid := nil;

    end;

  end

  else

    Result := GetLastError;

end;

const

  UNLEN = 256; // lmcons.h

// Template:

// http://www.latiumsoftware.com/en/pascal/0014.php

function _getLoginNameW: widestring;

var

  Buffer: array[0..UNLEN] of widechar;

  Size: DWORD;

begin

  Size := SizeOf(Buffer);

  if GetUserNameW(Buffer, Size) then

    Result := Buffer

  else

    Result := 'User';

end;

function _ConvertSidToStringSidA(SID: PSID; var strSID: LPSTR): boolean;

type

  DllReg = function(SID: PSID; var StringSid: LPSTR): Boolean; stdcall;

var

  hDll: THandle;

  dr: DllReg;

begin

  result := false;

  hDll := LoadLibrary(advapi32);

  if hDll <> 0 then

  begin

    @dr := GetProcAddress(hDll, 'ConvertSidToStringSidA');

    if assigned(dr) then

    begin

      result := dr(SID, strSID);

    end;

  end;

end;

const

  winternl_lib = 'Ntdll.dll';

type

  USHORT = Word;

  PWSTR = PWidechar;

  PCWSTR = PWideChar;

   NTSTATUS = Longword;

  _UNICODE_STRING = record

    Length: USHORT;

    MaximumLength: USHORT;

    Buffer: PWSTR;

  end;

  UNICODE_STRING = _UNICODE_STRING;

  PUNICODE_STRING = ^UNICODE_STRING;

function _RtlConvertSidToUnicodeString(

  UnicodeString: PUNICODE_STRING;

  Sid: PSID;

  AllocateDestinationString: BOOLEAN): NTSTATUS; stdcall;

type

  DllReg = function(UnicodeString: PUNICODE_STRING;

  Sid: PSID;

  AllocateDestinationString: BOOLEAN): NTSTATUS; stdcall;

var

  hDll: THandle;

  dr: DllReg;

begin

  result := $FFFFFFFF;

  hDll := LoadLibrary(winternl_lib);

  if hDll = 0 then Exit;

  try

    @dr := GetProcAddress(hDll, 'RtlConvertSidToUnicodeString');

    if not Assigned(dr) then Exit;

    result := dr(UnicodeString, Sid, AllocateDestinationString);

  finally

    FreeLibrary(hDll);

  end;

end;

procedure _RtlFreeUnicodeString(UnicodeString: PUNICODE_STRING); stdcall;

type

  DllReg = procedure(UnicodeString: PUNICODE_STRING); stdcall;

var

  hDll: THandle;

  dr: DllReg;

begin

  hDll := LoadLibrary(winternl_lib);