How to get the file name (and directory) of a file in the clipboard

Problem/Question/Abstract:

I need to have the filename and directory of the file which is in the clipboard. For example: In the Explorer I select a file, press ctrl+c and in my application I would like copy or do anything with it.

Answer:

procedure TMainForm.Button1Click(Sender: TObject);
var
  hDrop: THandle;
  cnt, i: Integer;
  filename: array[0..MAX_PATH - 1] of Char;
begin
  if ClipBoard.HasFormat(CF_HDROP) then
  begin
    hDrop := ClipBoard.GetAsHandle(CF_HDROP);
    cnt := DragQueryFile(hDrop, $FFFFFFFF, nil, 0);
    Memo.Clear;
    Memo.Lines.Add(Format('Found %d files:', [cnt]));
    for i := 0 to cnt - 1 do
    begin
      DragQueryFile(hDrop, i, @filename, MAX_PATH);
      Memo.lines.Add(Format('%2d: %s', [i + 1, filename]));
    end;
  end
  else
    MessageDlg(' No filename in clipboard!', mtInformation, [mbOk], 0);
end;

Accessing HotMail from Delphi

Problem/Question/Abstract:

Is it possible to access a HotMail account through the POP3 and SMTP? I know its a web front end but I'd like to write a automated application which can send and receive mail using a HotMail account.

Answer:

HotMail is not accessible through POP/SMTP. you must use their web interface.

There is no possible shortcut to read mail but you can open the default HotMail account in new message mode using this ShellExecute call:


program dummy;

var
  ToAddress: string;
  EightSpaces: string;

begin
  ToAddress := 'john@pacbell.net';
  // Don't know why but this is required to get the
  // correct compose address...
  EightSpaces := '        ';
  ShellExecute(Handle, PChar('open'), PChar('rundll32.exe'),
    PChar('C:\PROGRA~1\INTERN~1\HMMAPI.DLL,MailToProtocolHandler'
    + EightSpaces + ToAddress), nil, SW_NORMAL)
end.

How to get the system's colour palette

Problem/Question/Abstract:

I would like to automatically select colours for painting. At program start I want to use the 16 colour palette. Should the user need more colours, I would like to switch to the 256 colour palette. How can I do this?

Answer:

You can retrieve the system palette. Palettes are normally used in 16 and 256 colour mode, but the Highcolor mode also uses a system palette, which defines a range of standard colours. The following example shows how to retrieve the system palette in 256c mode:


procedure TForm1.Button1Click(Sender: TObject);
type
  TPal = array[0..255] of TPaletteEntry;
var
  pPal: ^TPal;
  i, numEntries: Integer;
begin
  pPal := nil;
  numEntries := GetSystemPaletteEntries(Canvas.handle, 0, 8, pPal^);
  if numEntries > 256 then
    numEntries := 256;
  pPal := AllocMem(numEntries * Sizeof(TPaletteEntry));
  GetSystemPaletteEntries(Canvas.Handle, 0, numEntries, pPal^);
  memo1.clear;
  for i := 0 to numEntries - 1 do
    with pPal^[i] do
      memo1.lines.add(Format('Color %d: R= %d, G= %d, B= %d', [i, pered, pegreen, peblue]));
end;

Get the local charset of a system

Problem/Question/Abstract:

How to get the local charset of a system

Answer:

function TranslateCharsetInfoEx(lpSrc: PDWORD; var lpCs: TCharsetInfo;
  dwFlags: DWORD): BOOL; stdcall; external 'gdi32.dll' name 'TranslateCharsetInfo';

procedure SetLocaleCharset;
var
  LCID, CP: Cardinal;
  Buf: array[0..6] of Char;
  CSI: TCharsetInfo;
begin
  LCID := GetThreadLocale;
  GetLocaleInfo(LCID, LOCALE_IDefaultAnsiCodePage, Buf, 6);
  CP := StrToIntDef(Buf, GetACP);
  TranslateCharsetInfoEx(Pointer(CP), CSI, TCI_SRCCODEPAGE);
  LocaleCharSet := CSI.ciCharset;
end;

Solving some problems of the TRichEdit component

Problem/Question/Abstract:

Solving some problems of the TRichEdit component.

Answer:

Problem 1
========
If you work with a TRichEdit, you'll find out that it has some problems.
In the Delphi help files you'll find a FindText and a ReplaceText
procedure as an example. Those procedures work fine on most operating
systems, but NOT on Windows 2000! If you set RichEdit1.SelStart and
RichEdit1.SelLength, under most operating systems the RichEdit scrolls
to the selected text. But not on Windows 2000. There you'll have to add
a: SendMessage(EM_SCROLLCARET,0,0); after you made the selection with
SelStart and SelLength. Only then the RichEdit under Windows 2000 will
scroll to the position of the cursor!

Problem 2
========
If you drop a RichEdit on a form, Delphi (5) doesn't add the richedit.dcu
unit to your uses clause. However, if you have included the richedit.dcu
unit yourself (manually) to your uses clause, then the following problem
occures:

In the unit "messages.dcu": EM_SCROLLCARET is defined as:
   EM_SCROLLCARET = $00B7;
  
In the unit "richedit.dcu": EM_SCROLLCARET is defined as:
   EM_SCROLLCARET = WM_USER + 49;
  
Because WM_USER is defined as $0400 (in messages.dcu) the value of
EM_SCROLLCARET becomes: $400 + 49 (decimal) = 1073 (decimal) after you
have added "richedit" to your uses clause. And that is the reason why
EM_SCROLLCARET will not work anymore... (At least under W2000. I didn't
test it on other operating systems.)

A workaround for this problem is to globally add:

Const
   EM_SCROLLCARET = $00B7;
  
to your unit.            

How to use non-standard colors in Windows

Problem/Question/Abstract:

My client wants to preserve a unique look and feel that does not depend upon the Windows color settings. For example, no matter what color the user has selected for his button color, my client wants to define the color for his application. A specific example involves SpinEdits. I'd like to define the color of the edit and the spin buttons. The easiest way for me to do this is to be able to redefine Windows colors internal to my application.

Answer:

The problem is more complicated as it seems at first glance. If your application stays on top long enough and you are pretty sure that the users aren't switching between apps at runtime, you can change the colors system wide. The sample below (quite simple, but enough to give you an idea how to do it) will help you to have the same colors on all machines, independent of the user choice. The advantage of this approach is, that you are able to use standard controls (which works fine most of the time).

In this sample I am changing 11 options. Have a look in the help files for all available options.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  tarr = array[1..11] of integer;
  TForm1 = class(TForm)
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure FormDeactivate(Sender: TObject);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  ind: tarr;

implementation

{$R *.DFM}

procedure TForm1.Button2Click(Sender: TObject);
var
  p1, p2: tarr;
begin
  p1[1] := COLOR_ACTIVEBORDER;
  p1[2] := COLOR_APPWORKSPACE;
  p1[3] := COLOR_BTNFACE;
  p1[4] := COLOR_BTNHILIGHT;
  p1[5] := COLOR_BTNSHADOW;
  p1[6] := COLOR_BTNTEXT;
  p1[7] := COLOR_GRAYTEXT;
  p1[8] := COLOR_INACTIVEBORDER;
  p1[9] := COLOR_INACTIVECAPTION;
  {p1[9] := COLOR_INACTIVECAPTIONTEXT;}
  p1[10] := COLOR_MENU;
  p1[11] := COLOR_SCROLLBAR;
  p2[1] := 128 * 16 * 16 * 16 * 16 + 111 * 16 * 16 + 150;
  p2[2] := 84 * 16 * 16 * 16 * 16 + 72 * 16 * 16 + 100;
  p2[3] := 128 * 16 * 16 * 16 * 16 + 111 * 16 * 16 + 150;
  p2[4] := 192 * 16 * 16 * 16 * 16 + 184 * 16 * 16 + 203;
  p2[5] := 84 * 16 * 16 * 16 * 16 + 72 * 16 * 16 + 100;
  p2[6] := 0;
  p2[7] := 84 * 16 * 16 * 16 * 16 + 72 * 16 * 16 + 100;
  p2[8] := 128 * 16 * 16 * 16 * 16 + 111 * 16 * 16 + 150;
  p2[9] := 84 * 16 * 16 * 16 * 16 + 72 * 16 * 16 + 100;
  p2[10] := 128 * 16 * 16 * 16 * 16 + 111 * 16 * 16 + 150;
  p2[11] := 192 * 16 * 16 * 16 * 16 + 184 * 16 * 16 + 203;
  setsyscolors(11, p1, p2);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  p1: tarr;
begin
  p1[1] := COLOR_ACTIVEBORDER;
  p1[2] := COLOR_APPWORKSPACE;
  p1[3] := COLOR_BTNFACE;
  p1[4] := COLOR_BTNHILIGHT;
  p1[5] := COLOR_BTNSHADOW;
  p1[6] := COLOR_BTNTEXT;
  p1[7] := COLOR_GRAYTEXT;
  p1[8] := COLOR_INACTIVEBORDER;
  p1[9] := COLOR_INACTIVECAPTION;
  {p1[9] := COLOR_INACTIVECAPTIONTEXT;}
  p1[10] := COLOR_MENU;
  p1[11] := COLOR_SCROLLBAR;
  setsyscolors(11, p1, ind);
end;

procedure TForm1.FormDeactivate(Sender: TObject);
var
  p1: tarr;
begin
  p1[1] := COLOR_ACTIVEBORDER;
  p1[2] := COLOR_APPWORKSPACE;
  p1[3] := COLOR_BTNFACE;
  p1[4] := COLOR_BTNHILIGHT;
  p1[5] := COLOR_BTNSHADOW;
  p1[6] := COLOR_BTNTEXT;
  p1[7] := COLOR_GRAYTEXT;
  p1[8] := COLOR_INACTIVEBORDER;
  p1[9] := COLOR_INACTIVECAPTION;
  {p1[9] := COLOR_INACTIVECAPTIONTEXT;}
  p1[10] := COLOR_MENU;
  p1[11] := COLOR_SCROLLBAR;
  setsyscolors(11, p1, ind);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ind[1] := getsyscolor(COLOR_ACTIVEBORDER);
  ind[2] := getsyscolor(COLOR_APPWORKSPACE);
  ind[3] := getsyscolor(COLOR_BTNFACE);
  ind[4] := getsyscolor(COLOR_BTNHILIGHT);
  ind[5] := getsyscolor(COLOR_BTNSHADOW);
  ind[6] := getsyscolor(COLOR_BTNTEXT);
  ind[7] := getsyscolor(COLOR_GRAYTEXT);
  ind[8] := getsyscolor(COLOR_INACTIVEBORDER);
  ind[9] := getsyscolor(COLOR_INACTIVECAPTION);
  {ind[9] := getsyscolor(COLOR_INACTIVECAPTIONTEXT);}
  ind[10] := getsyscolor(COLOR_MENU);
  ind[11] := getsyscolor(COLOR_SCROLLBAR);
  application.OnDeactivate := formdeactivate;
  application.OnActivate := button2click;
end;

end.

How to get a list of all network adapters of a PC

Problem/Question/Abstract:

How to get a list of all network adapters of a PC

Answer:

Example which can be used for all other hardware, too. Doesn't seem to work for Win 2000 though.

uses
  Registry;

procedure GetNetworkAdapters(const List: TStrings);
var
  R: TRegistry;
  i: Integer;
begin
  List.BeginUpdate;
  try
    R := TRegistry.Create;
    try
      R.RootKey := HKEY_DYN_DATA;
      if R.OpenKeyReadOnly('\Config Manager\Enum') then
      try
        R.GetKeyNames(List);
      finally
        R.CloseKey;
      end;
      for i := List.Count - 1 downto 0 do
        if (List[i] = '') or
                                        not R.OpenKeyReadOnly('\Config Manager\Enum\' + List[i]) then
          List.Delete(i)
        else
        try
          List[i] := R.ReadString('HardwareKey');
        finally
          R.CloseKey;
        end;
      R.RootKey := HKEY_LOCAL_MACHINE;
      for i := List.Count - 1 downto 0 do
        if (List[i] = '') or not R.OpenKeyReadOnly('\Enum\' + List[i]) then
          List.Delete(i)
        else
        try
          if CompareText(R.ReadString('Class'), 'net') = 0 then
            List[i] := R.ReadString('DeviceDesc')
          else
            List.Delete(i);
        finally
          R.CloseKey;
        end;
    finally
      R.Free;
    end;
  finally
    List.EndUpdate;
  end;
end;

How to disable the CD autorun feature through code

Problem/Question/Abstract:

How to disable the CD autorun feature through code

Answer:

Solve 1:

uses
  Registry;

function IsCdAutoRunOn: bool;
var
  reg: TRegistry;
  AutoRunSetting: integer;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CURRENT_USER;
  reg.OpenKey('Software\Microsoft\Windows\' + 'CurrentVersion\Policies\Explorer',
    false);
  reg.ReadBinaryData('NoDriveTypeAutoRun', +AutoRunSetting, sizeof(AutoRunSetting));
  reg.CloseKey;
  reg.free;
  result := not ((AutoRunSetting and (1 shl 5)) <> 0);
end;

procedure SetCdAutoRun(bOn: bool);
var
  reg: TRegistry;
  AutoRunSetting: integer;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CURRENT_USER;
  reg.LazyWrite := false;
  reg.OpenKey('Software\Microsoft\Windows\' + 'CurrentVersion\Policies\Explorer',
    false);
  reg.ReadBinaryData('NoDriveTypeAutoRun', +AutoRunSetting, sizeof(AutoRunSetting));
  if bOn then
    AutoRunSetting := AutoRunSetting and not (1 shl 5)
  else
    AutoRunSetting := AutoRunSetting or (1 shl 5);
  reg.WriteBinaryData('NoDriveTypeAutoRun', +AutoRunSetting, sizeof(AutoRunSetting));
  reg.CloseKey;
  reg.free;
end;


Solve 2:

After an hour of tinkering with some samples on the Internet I came up with the proper registry setting to turn on/off the CDROM AutoRun feature. The first thing wrong with all the samples was the type of value we need to store in the registry, I found that binary is what works. The next thing most samples neglected to say, besides being just wrong, was that you need to reboot your system after making the change. This tip was tested on Windows98, so this registry setting may differ a little for other operating systems. We will be using the TRegistry object using TRegistry.KeyExists, TRegistry.OpenKey, and TRegistry.WriteBinaryData

First we will need to add Registry to our unit's uses clause
Next we will need a TButton and a TButton.OnClick event. You can easily create this event through the Object Inspector Events tab
We will then declare a new procedure that will make the settings according to the boolean parameter sent in
In our routine we will first create our TRegistry object, then we will set the TRegistry.RootKey. Next we will check to see if the CDROM registry key exists before trying to open it. After opening the CDROM registry key we will add AutoRun to it according to the boolean parameter sent into the procedure
TRegistry.KeyExists returns TRUE is the specified registry key exists. The only parameter is a string to the key in the registry. If we set TRegistry.RootKey then we do not have to specify it within the string parameter
TRegistry.OpenKey returns TRUE if the specified registry key opens successfully. The first parameter is a string to the key in the registry. As mentioned above, if we set TRegistry.RootKey then we do not have to specify it within the string parameter. The second parameter is a boolean value telling Windows whether or not to create the key if it does not exist, we will set this to FALSE
TRegistry.WriteBinaryData stores binary data to the registry. The first parameter is the name to stoe under the open registry key. The second parameter is the value to store. The last parameter is the size of the binary value we are storing


{...}

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure SetCDAutoRun(AAutoRun: Boolean);
  public
    { Public declarations }
  end;

  {...}

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetCDAutoRun(FALSE);
end;

procedure TForm1.SetCDAutoRun(AAutoRun: Boolean);
const
  DoAutoRun: array[Boolean] of Integer = (0, 1);
var
  Reg: TRegistry;
begin
  try
    { create our registry object }
    Reg := TRegistry.Create;
    { set our registry root key }
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    { verify that our CDROM class key exists }
    if Reg.KeyExists('System\CurrentControlSet\Services\Class\CDROM') then
      { try to open our CDROM class key }
      if Reg.OpenKey('System\CurrentControlSet\Services\Class\CDROM', FALSE) then
        { add AutoRun to our CDROM class key }
        Reg.WriteBinaryData('AutoRun', DoAutoRun[AAutoRun], 1);
  finally
    { free our registry object }
    Reg.Free;
  end;
  { showmessage that the changes will happen on reboot }
  ShowMessage('Your settings will take effect on the next reboot of Windows.');
end;

{...}

How to minimize and restore all open applications

Problem/Question/Abstract:

How to minimize and restore all open applications

Answer:

procedure MinimizeAll;
begin
  { [Window key] + 'M' minimizes all windows, [Win][Shift] + 'M' restores them }
  keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), 0, 0);
  keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), 0, 0);
  keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), KEYEVENTF_KEYUP, 0);
  keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), KEYEVENTF_KEYUP, 0);
end;

procedure UnMinimizeAll;
begin
  { [Window key] + 'M' minimizes all windows, [Win][Shift] + 'M' restores them }
  keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), 0, 0);
  keybd_event(VK_SHIFT, MapvirtualKey(VK_SHIFT, 0), 0, 0);
  keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), 0, 0);
  keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), KEYEVENTF_KEYUP, 0);
  keybd_event(VK_SHIFT, MapvirtualKey(VK_SHIFT, 0), KEYEVENTF_KEYUP, 0);
  keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), KEYEVENTF_KEYUP, 0);
end;

"ntdll.DbgUserBreakPoint" during debug startup

Problem/Question/Abstract:

Whenever I start a program from the IDE with debugging enabled, the CPU window pops up and it reports something like ntdll.DbgUserBreakPoint - but I do not have any breakpoints set in my project.

Answer:

This is debug code in NTDLL.DLL itself. It gets executed if you have more than 16 colors for the application icon. You can help yourself by changing the number of colors for icons (Control Panel, Display Properties).

Microsoft must have hard-coded a debug breakpoint (int 3) in ntdll.dll to trace a bug and then they forgot to take it out for final build of Windows NT.

Insert a row in a TStringGrid at a certain position

Problem/Question/Abstract:

Is there a method to insert a row into a StringGrid or do I have to shuffle all higher rows up 1?

Answer:

TCustomGrid has a very useful but unfortunately protected method named MoveRow. You can get at it using the cracker class strategy:

type
  TGridCracker = class(TCustomGrid);

{insert a line at row 5}
stringgrid1.rowcount := stringgrid1.rowcount + 1;
TGridCracker(stringgrid1).Moverow(stringgrid1.rowcount - 1, 5);

You first add a new empty line, then move it to the required position. This automatically moves all following lines one position down.

Several color rows in TStringGrid

Problem/Question/Abstract:

Show several color in the rows of a TStringGrid.

Answer:

Using the OnDrawCell event...

Put this code in the event OnDrawCell of the StringGrid:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  with (Sender as TStringGrid) do begin
    if (Arow And 1)=1 then Canvas.Font.Color := clRed   { En rojo / in red }
                      else Canvas.Font.Color := clBlue; { En Azul / in Blue }

    Canvas.TextRect( Rect,
                     Rect.Left + 2,
                     Rect.Top + 2,
                     Cells[Acol,Arow]);
  end;
end;

This example shows the even lines with a color and the odd with other...

How to convert a word wrap in a TMemo to a CR/LF

Problem/Question/Abstract:

Using a TMemo, is it possible to convert each wrap to a CR/LF, or even at a specific column (like 67 or 80)?

Answer:

const
  limit = 67;
var
  S: string;
  i: Integer;
begin
  S := Memo1.Text;
  Memo1.Clear;
  repeat
    i := limit;
    while S[i] <> ' ' do
      Dec(i);
    Memo1.Lines.Add(Trim(Copy(S, 1, i)));
    Delete(S, 1, i);
  until
    Length(S) = 0;
end;

AdjustTokenPrivileges function to enable a privilege (NT)

Problem/Question/Abstract:

For some functions you need to get the right privileges on a Windows NT machine. (e.g: To shut down or restart windows with ExitWindowsEx or to change the system time)

Answer:

The following code provides a procedure to adjust the privileges. The AdjustTokenPrivileges() function enables or disables privileges in the specified access token.

// NT Defined Privileges from winnt.h

const
  SE_CREATE_TOKEN_NAME = 'SeCreateTokenPrivilege';
  SE_ASSIGNPRIMARYTOKEN_NAME = 'SeAssignPrimaryTokenPrivilege';
  SE_LOCK_MEMORY_NAME = 'SeLockMemoryPrivilege';
  SE_INCREASE_QUOTA_NAME = 'SeIncreaseQuotaPrivilege';
  SE_UNSOLICITED_INPUT_NAME = 'SeUnsolicitedInputPrivilege';
  SE_MACHINE_ACCOUNT_NAME = 'SeMachineAccountPrivilege';
  SE_TCB_NAME = 'SeTcbPrivilege';
  SE_SECURITY_NAME = 'SeSecurityPrivilege';
  SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege';
  SE_LOAD_DRIVER_NAME = 'SeLoadDriverPrivilege';
  SE_SYSTEM_PROFILE_NAME = 'SeSystemProfilePrivilege';
  SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
  SE_PROF_SINGLE_PROCESS_NAME = 'SeProfileSingleProcessPrivilege';
  SE_INC_BASE_PRIORITY_NAME = 'SeIncreaseBasePriorityPrivilege';
  SE_CREATE_PAGEFILE_NAME = 'SeCreatePagefilePrivilege';
  SE_CREATE_PERMANENT_NAME = 'SeCreatePermanentPrivilege';
  SE_BACKUP_NAME = 'SeBackupPrivilege';
  SE_RESTORE_NAME = 'SeRestorePrivilege';
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
  SE_DEBUG_NAME = 'SeDebugPrivilege';
  SE_AUDIT_NAME = 'SeAuditPrivilege';
  SE_SYSTEM_ENVIRONMENT_NAME = 'SeSystemEnvironmentPrivilege';
  SE_CHANGE_NOTIFY_NAME = 'SeChangeNotifyPrivilege';
  SE_REMOTE_SHUTDOWN_NAME = 'SeRemoteShutdownPrivilege';
  SE_UNDOCK_NAME = 'SeUndockPrivilege';
  SE_SYNC_AGENT_NAME = 'SeSyncAgentPrivilege';
  SE_ENABLE_DELEGATION_NAME = 'SeEnableDelegationPrivilege';
  SE_MANAGE_VOLUME_NAME = 'SeManageVolumePrivilege';

  // Enables or disables privileges depending on the bEnabled value

function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean;
var
  hToken: THandle;
  TokenPriv: TOKEN_PRIVILEGES;
  PrevTokenPriv: TOKEN_PRIVILEGES;
  ReturnLength: Cardinal;
begin
  Result := True;
  // Only for Windows NT/2000/XP and later.
  if not (Win32Platform = VER_PLATFORM_WIN32_NT) then
    Exit;
  Result := False;

  // obtain the processes token
  if OpenProcessToken(GetCurrentProcess(),
    TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
  begin
    try
      // Get the locally unique identifier (LUID) .
      if LookupPrivilegeValue(nil, PChar(sPrivilege),
        TokenPriv.Privileges[0].Luid) then
      begin
        TokenPriv.PrivilegeCount := 1; // one privilege to set

        case bEnabled of
          True: TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
          False: TokenPriv.Privileges[0].Attributes := 0;
        end;

        ReturnLength := 0; // replaces a var parameter
        PrevTokenPriv := TokenPriv;

        // enable or disable the privilege

        AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv),
          PrevTokenPriv, ReturnLength);
      end;
    finally
      CloseHandle(hToken);
    end;
  end;
  // test the return value of AdjustTokenPrivileges.
  Result := GetLastError = ERROR_SUCCESS;
  if not Result then
    raise Exception.Create(SysErrorMessage(GetLastError));
end;