-- Page 1
--
Last updated: 02/18/2005
Below is a list of Delphi code tips that I have come across from personal experience and various newsgroups. I collect bits and pieces of code that I find very useful and place them all in one unit so they are accessed easily in other Delphi projects. You are free to download this unit here.
Download the unit containing all the
source found on these Code Tips pages by clicking on the spinning
disk on the left or here. You will need WinZip or Pkunzip to unzip the file. After
unzipping the unit to a directory of your choice, simply add it
to your project's uses clause and you're ready to use the code.
Note: all of this code has been tested and compiled in Delphi 3, 4 & 5. If you find ANY problems with compiling or running the code in your project, please let me know and I will do my best to help resolve your issue. Thanks!
Sometimes you want to deactivate the current screensaver when performing some very long process. You can use this function to activate or deactivate the screensaver. Pass True to activate it, or False to deactivate it.
function
ActivateScreenSaver(Activate: boolean):
boolean;
{
func to activate or deactivate the screensaver. }
var
IntActive:
byte;
begin
{ False (0)
is off, True (1) is on. }
if
Activate then
IntActive := 1
else
IntActive := 0;
Result :=
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, IntActive, nil,
0);
end;
Here's a bit of code to show you how to add your own custom menu items to your form's system menu (the icon on the top left corner of your form during runtime). See the comments for code you need to add to your form.
procedure
AddSystemMenuItem(Menu: hMenu; Caption: string; id: UINT);
{ Adds
menu items to the system menu handle. }
(*******************************
Usage:
private
procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
procedure TForm1.WMSysCommand(var Message: TWMSysCommand);
begin
{ Be sure you are using the correct CmpType as you assigned }
{ in your AddMenuItem() calls. }
if Message.CmdType = 1 then
ShowMessage('Hello, World!')
else
inherited;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
MenuHandle: THandle;
begin
MenuHandle := GetSystemMenu(Handle, False);
AddSystemMenuItem(MenuHandle, '-', 0);
AddSystemMenuItem(MenuHandle, '&Hello, World!', 1);
end;
********************************)
var
mii:
TMenuItemInfo;
begin
mii.fMask := MIIM_ID
or MIIM_TYPE or MIIM_DATA;
if Caption
= '-' then
mii.fType
:= MFT_SEPARATOR
else
mii.fType
:= MFT_STRING;
mii.wID := id;
mii.dwTypeData :=
PChar(Caption);
mii.cbSize :=
SizeOf(TMenuItemInfo);
InsertMenuItem(Menu,
GetMenuItemCount(Menu), TRUE, mii);
end;
We deal with paths all the time, and I hate to check for the last backslash before appending a filename to the path. I made this function to check for the backslash and either add one or remove it. Usage: FileAndPathStr := BackSlash(SomeDirectory, _ADD) + 'TheFile.tmp';
type
BackSlashAction =
(_ADD, _REMOVE);
function BackSlash(Dir:
string; Action: BackSlashAction): string;
begin
case
Action of
_ADD:
begin
if Copy(Dir, Length(Dir), 1) = '\' then
Result := Dir
else
Result := Dir + '\';
end;
_REMOVE:
begin
if Copy(Dir, Length(Dir), 1) = '\' then
Result := Copy(Dir, 1, Length(Dir)-1)
else
Result := Dir;
end;
end;
end;
This function will take a string, lowercase it, and uppercase the first characters of all the words in the string. For ex.: 'the quick brown fox' will become 'The Quick Brown Fox'. Thanks to Sanford Aranoff for this code.
function
Capitalize(const
Line1: string): string;
{ Func
to capitalize the first char of every word.
}
{ Code adapted from Sanford Aranoff <[email protected]> }
const
period = '.';
comma = ',';
slash = '/';
bslash = '\';
blank = ' ';
set_let_next = [period,'-'];
set_let_prev = [period,slash,bslash,'-',comma,'"'];
var
let: char;
i, j: integer;
test: boolean;
function
LineIsNull(const Source: string): boolean;
{Determine
if a string contains only char. 0-32.}
asm
Push ESI //save the important stuff
Mov @Result,true
Or EAX,EAX
Jz @Done //abort if nil address
Mov ESI,EAX //put address into read register
Mov ECX,[EAX-4] //put length into count register
Jecxz @NG //bail out if zero length
Cld //make sure we go forward
@Start:
Lodsb //get a byte
Cmp AL,32 //greater than space?
Ja @NG //yes, then abort
Dec ECX //do it again
Jnz @Start
Mov EAX,-1 //if we make it here, it's a null
string
Jmp @Done
@NG:
xor EAX,EAX
Mov @Result,false
@Done:
Pop
ESI //restore
the important stuff
end;
begin
if
LineIsNull(line1) then
begin
Result:= '';
Exit;
end;
Result := Trim(Line1);
i := Length(Result);
if i = 1 then
begin
Result[1] := UpCase(Result[1]);
Exit;
end;
Result := LowerCase(Result);
Result[1] :=
UpCase(Result[1]);
j := 1;
repeat
Let :=
Result[j];
inc(j);
Test
:= (Let <= blank) or (Let in set_let_prev);
if
not test then
begin
if j > 2 then
Let := Result[j-2]
else
Let := Blank;
Test := (Let <= blank) or (Let in set_let_prev);
if test then
begin
if j < i then
begin
if j <= 2 then
Test := Result[j+1] in [Period ,'-', Blank]
else
Test := Result[j+1] in set_let_next;
end
else
Test := False;
end;
end;
if
Test then
Result[j] := UpCase(Result[j]);
until
j = i;
end;
Some functions will return a TFileTime type (_FILETIME structure in WinAPI) such as GetProcessTimes(), GetThreadTimes(), GetFileTime(), etc. This function will convert that value to a readable date/time string. Read the comment for the usage. You can change the format of the resulting date string in the FormatDateTime() function any way you please. Thanks to Phil Stubbington <http://www.ambitus.co.uk> for this code. If you want just the modified date of a file, see GetModifiedDate() on page 2.
function
FileTimeToLongStr(ft : TFileTime): string;
{ func
to convert TFileTime to readable date/time. }
{ Thanks to Phil Stubbington for this code. }
{ Email: [email protected] Web: http://www.ambitus.co.uk }
(* Usage:
procedure TForm1.Button1Click(Sender: TObject);
var
fs: TFileStream;
CreateTime,
LastAccessTime,
WriteTime: TFileTime;
CreateTimeStr,
LastAccessTimeStr,
WriteTimeStr: string;
begin
fs := TFileStream.Create('C:\SomeDir\SomeFile.tmp',
fmOpenRead or fmShareDenyNone);
try
GetFileTime(fs.Handle, @CreateTime,
@LastAccessTime, @WriteTime);
CreateTimeStr :=
FileTimeToLongStr(CreateTime);
LastAccessTimeStr :=
FileTimeToLongStr(LastAccessTime);
WriteTimeStr :=
FileTimeToLongStr(WriteTime);
{ ... }
finally
fs.Destroy;
end;
end; *)
var
st: TSystemTime;
begin
{ convert FileTime to local time zone }
if FileTimeToLocalFileTime(ft, ft) then
{ convert to SystemTime }
if FileTimeToSystemTime(ft,
st) then
{ Convert to TDateTime }
Result := FormatDateTime('dd
mmmm yyyy hh:mm:ss', SystemTimeToDateTime(st))
else
Result := ''
else
Result := '';
end;
Every once in a while you'll come across a negative number string in the form of '(1234.56)' such as in MS Excel or other apps. This function will convert that string into a negative sign string such as '-1234.56'. Thanks to Jeff Hamblin <[email protected]> for this code. Note: this function uses DeleteCharsFromString() found on page 3.
function
FixParenthesisNeg(const AmntStr: string): string;
{ func
to convert a parenthesis negative string number to
}
{ a negative sign string number.
}
{ Note: code uses DeleteCharsFromString() func.
}
{ e.g. FixParenthesisNeg('(123.45)') will return '-123.45'
}
{ Thanks to Jeff Hamblin for this code. Email: [email protected] }
{ Web: http://www.qtools.com
}
begin
Result := AmntStr;
if AmntStr <> '' then
if AmntStr[1] = '(' then
begin
Result :=
DeleteCharsFromString(AmntStr, ['(', ')']);
Result := '-' +
Result;
end;
end;
CopyAllFiles() will copy a set of files or a directory of your choice. It also displays the same animation of the operation as does Windows Explorer. You can pass wildcards to the function. In order to copy a directory, do not include the last backslash. For example: CopyAllFiles('C:\ThisDirectory', 'C:\AnotherDirectory', False); The 'False' parameter tells the function to not rename files if they already exist. If set to 'True', the new files will have 'Copy of ...' appended to the name.
Update: Raghavendra Rao gave me a fix for an AV that sometimes occurred on NT systems: add FillChar() call at the beginning of the function.
uses ShellAPI;
function CopyAllFiles(sFrom,
sTo: string; Protect: boolean): boolean;
{ Copies
files or directory to another directory. }
var
F: TShFileOpStruct;
ResultVal: integer;
tmp1, tmp2: string;
begin
FillChar(F, SizeOf(F), #0);
Screen.Cursor := crHourGlass;
try
F.Wnd := 0;
F.wFunc := FO_COPY;
{ Add
an extra null char }
tmp1 := sFrom + #0;
tmp2 := sTo + #0;
F.pFrom := PChar(tmp1);
F.pTo := PChar(tmp2);
if
Protect then
F.fFlags := FOF_RENAMEONCOLLISION or FOF_SIMPLEPROGRESS
else
F.fFlags := FOF_SIMPLEPROGRESS;
F.fAnyOperationsAborted
:= False;
F.hNameMappings
:= nil;
Resultval := ShFileOperation(F);
Result := (ResultVal = 0);
finally
Screen.Cursor := crDefault;
end;
end;
If you deal with graphics, sometimes you want to get the number of colors used in a bitmap. Call CountColors() passing the TBitmap to return an integer value. This code was adapted from Earl F. Glynn.
//
Count number of unique R-G-B triples in a pf24bit Bitmap only.
//
Code adapted from Earl F. Glynn
//
email: [email protected]
//
web page: http://www.efg2.com/lab/
function
CountColors(const Bitmap: TBitmap): integer;
type
pRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..MaxPixelCount-1] of
TRGBTriple;
var
Flags:
array[byte, byte] of TBits;
i, j, k:integer;
rowIn:
pRGBTripleArray;
begin
// Be sure bitmap is 24-bits/pixel
assert(Bitmap.PixelFormat
= pf24Bit);
// Clear 2D array of TBits objects
for
j := 0 to 255 do
for i := 0 to 255 do
Flags[i,j] := nil;
// Step through each scanline of image
for
j := 0 to Bitmap.Height-1 do
begin
rowIn := Bitmap.Scanline[j];
for i := 0 to Bitmap.Width-1 do
begin
with rowIn[i] do
begin
if not Assigned(Flags[rgbtRed, rgbtGreen]) then
begin
//
Create 3D column when needed
Flags[rgbtRed, rgbtGreen] := TBits.Create;
Flags[rgbtRed, rgbtGreen].Size := 256;
end;
// Mark this
R-G-B triple
Flags[rgbtRed,rgbtGreen].Bits[rgbtBlue] := True;
end;
end;
end;
Result := 0;
// Count and Free TBits objects
for
j := 0 to 255 do
begin
for i := 0 to 255 do
begin
if Assigned(Flags[i,j]) then
begin
for k := 0 to 255 do
if Flags[i,j].Bits[k] then
Inc(Result);
Flags[i,j].Free;
end;
end;
end;
end;
Here's how to create a shortcut on the desktop, start and programs menu, send to menu, quick launch toolbar, startup, favorites and documents folders. Simple usage is like this: CreateShortcut('c:\winnt\system32\notepad.exe', _DESKTOP); to create a shortcut of Notepad.exe on the desktop.
uses
Registry, ShlObj,
ActiveX, ComObj;
type
ShortcutType = (_DESKTOP, _QUICKLAUNCH, _SENDTO, _STARTMENU,
_DOCS, _STARTMENUINI, _STARTMENUPROGS, _FAVORITES);
procedure
CreateShortcut(FileName: string; Location:
ShortcutType);
{
proc to create a shortcut on the desktop or startmenu. }
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
Directory,
LinkName : string;
WFileName : WideString;
MyReg,
QuickLaunchReg : TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
MySLink.SetPath(PChar(FileName));
MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');
try
LinkName := ChangeFileExt(FileName, '.lnk');
LinkName := ExtractFileName(LinkName);
case Location of
_DESKTOP :
Directory := MyReg.ReadString('Shell Folders', 'Desktop', '');
_STARTMENU : Directory
:= MyReg.ReadString('Shell Folders', 'Start Menu', '');
_SENDTO
: Directory := MyReg.ReadString('Shell
Folders', 'SendTo', '');
_QUICKLAUNCH:
begin
QuickLaunchReg
:= TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\GrpConv');
try
Directory
:= QuickLaunchReg.ReadString('MapGroups', 'Quick Launch', '');
finally
QuickLaunchReg.Free;
end;
end;
_FAVORITES : Directory := MyReg.ReadString('Shell Folders', 'Favorites', '');
_STARTMENUPROGS: Directory := MyReg.ReadString('Shell Folders', 'Programs', '');
_STARTMENUINI : Directory := MyReg.ReadString('Shell Folders', 'StartUp', '');
_DOCS
: Directory := MyReg.ReadString('Shell Folders', 'Personal', '');
end;
if Directory <> ''
then
begin
WFileName :=
Directory + '\' + LinkName;
MyPFile.Save(PWChar(WFileName),
False);
end;
finally
MyReg.Free;
end;
end;
DeleteAllFiles() will delete a set of files or a directory of your choice and place them in the Recycle Bin. It also displays the same animation of the operation as does Windows Explorer. You can pass wildcards to the function. In order to delete a directory, do not include the last backslash. For example: DeleteAllFiles('C:\ThisDirectory');
Raghavendra Rao gave me a fix for an AV that sometimes occurred on NT systems: add FillChar() call at the beginning of the function.
Update: this update fixes the "System File Error: 1026" that sometimes appeared.
uses ShellAPI;
function
DeleteAllFiles(FilesOrDir: string): boolean;
{ Sends
files or directory to the recycle bin. }
var
F:
TSHFileOpStruct;
From: string;
Resultval:
integer;
begin
FillChar(F, SizeOf(F), #0);
From := FilesOrDir + #0;
Screen.Cursor := crHourGlass;
try
F.wnd
:= 0;
F.wFunc
:= FO_DELETE;
F.pFrom
:= PChar(From);
F.pTo
:= nil;
F.fFlags
:= FOF_ALLOWUNDO or
FOF_NOCONFIRMATION or
FOF_SIMPLEPROGRESS or
FOF_FILESONLY;
F.fAnyOperationsAborted
:= False;
F.hNameMappings
:= nil;
Resultval := ShFileOperation(F);
Result := (ResultVal = 0);
finally
Screen.Cursor := crDefault;
end;
end;
This function determines if a drive is a CDROM drive. An example of using this function is shown in OpenCloseCDDrive().
function
IsDriveCD(Drive: Char): boolean;
{
func to determine if a given drive is a CDROM drive. }
var
DrivePath:
string;
DriveResult: integer;
begin
DrivePath
:= Drive + ':\';
DriveResult := GetDriveType(PChar(DrivePath));
Result :=
DriveResult = DRIVE_CDROM;
end;
It's sometimes a good idea to check if a drive is ready before accessing it. Such a good case is the floppy drive. DiskInDrive() will check for the availability of the drive without those ugly Windows error messages. Pass the drive number to the function (you can use the GetDriveNumber() function to get the drive's number).
function DiskInDrive(DriveNumber:
integer): boolean;
{ func
to determine if a drive is ready or available. }
var
ErrorMode: word;
begin
{
turn off critical errors }
ErrorMode :=
SetErrorMode(SEM_FailCriticalErrors);
try
{ drive 1 = a, 2 = b, 3 = c, etc. }
Result := DiskSize(DriveNumber) <> -1;
finally
{ restore old error mode }
SetErrorMode(ErrorMode);
end;
end;
I have seen this one asked quite a few times: How do you get the week number of a given date? Pass a TDateTime variable to CalendarWeek() below and it will calculate and return the week number. Thanks to Ralph Friedman for this code.
function
CalendarWeek(ADate: TDateTime): integer;
{ Code
adapted from Ralph Friedman (TeamB) <[email protected]>
}
{
Calculates calendar week assuming:
- Monday
is the 1st day of the week.
- The 1st
calendar week is the 1st week
of the year that contains a Thursday.
If
result is 53, then previous year is assumed. }
var
firstOfYear:
TDateTime;
day,
dayOne,
month,
monthOne,
year: word;
begin
DecodeDate(ADate,
year, month, day);
dayOne := 0;
case DayOfWeek(EncodeDate(year,
1, 1)) of
1:
dayOne := 2; // Sunday
2:
dayOne := 1; // Monday
3:
dayOne := 31; // Tuesday
4:
dayOne := 30; // Wednesday
5:
dayOne := 29; // Thursday
6:
dayOne := 4; // Friday
7:
dayOne := 3; // Saturday
end;
if dayOne >
4 then
begin
Dec(year);
monthOne := 12
end
else
monthOne := 1;
firstOfYear := EncodeDate(year, monthOne, dayOne);
if ADate <
firstOfYear then
Result := 53
else
Result := (Trunc(ADate - firstOfYear) div 7) + 1;
end;
This procedure will enable or disable the system menu close button (the 'x' on the top right corner of the application). Pass False to disable it, True to enable it. This will also enable/disable the Close menu option of the application icon (top left corner). Note: your users will still be able to close the application by pressing ALT-F4.
procedure EnableSystemMenuCloseButton(Hnd: THandle; Enabled: boolean);
var
hMenu: THandle;
begin
{ Enable/Disable the system menu close button. }
hMenu := GetSystemMenu(Hnd, False);
if Enabled then
EnableMenuItem(hMenu, SC_CLOSE, MF_BYCOMMAND or
MF_ENABLED)
else
EnableMenuItem(hMenu, SC_CLOSE, MF_BYCOMMAND or MF_GRAYED);
end;
To display some text on a
canvas at a certain rotation, call the CanvasTextOutAngle()
procedure. Example: CanvasTextOutAngle(Form1.Canvas,
50, 50, 315, 'This is a test.');
Note: this will only work for true type fonts.
procedure CanvasTextOutAngle(C:
TCanvas; X, Y: integer; Angle: word; S: string);
{ Output text at any angle on a canvas. This will }
{ only work with TrueType fonts. }
{ Code adapted from ZieglerSoft [http://www.zieglersoft.dk/uk.html] }
var
LogRec: TLOGFONT;
OldFontHandle,
NewFontHandle: HFONT;
begin
GetObject(C.Font.Handle, SizeOf(LogRec), Addr(LogRec));
LogRec.lfEscapement := Angle*10; {10th of a degree}
LogRec.lfOrientation := Angle*10;
NewFontHandle := CreateFontIndirect(LogRec);
OldFontHandle := SelectObject(C.Handle, NewFontHandle);
C.Brush.Style := bsClear;
C.TextOut(X, Y, S);
NewFontHandle := SelectObject(C.Handle, OldFontHandle);
DeleteObject(NewFontHandle);
end;
To open or close the CDROM, call OpenCloseCD() passing either True (to open) or False (to close). This procedure will work on all types of CDs and will also work if there is no CDROM in the drive. This is similar to OpenCloseCDDrive() except that this one doesn't require a drive letter. Thanks to Bence Parhuzamos for this code.
uses MMSystem;
procedure
OpenCloseCD(TrueForOpenFalseForClose:
boolean);
{ Works
as well as OpenCloseCDDrive() above, }
{ but you don't have to specify a drive letter. }
{ Thanks to Bence Parhuzamos [[email protected]] for this code.
}
var
mci: TMCI_Open_Parms;
begin
FillChar(mci, SizeOf(mci), #0);
mci.lpstrDeviceType := PChar('CDAudio');
mciSendCommand(0, mci_Open, mci_Open_Type, Longint(@mci));
mciSendCommand(mci.wDeviceID, mci_Set, 256*(Byte(not
TrueForOpenFalseForClose)+1), 0);
{ MCI_SET_DOOR_OPEN = 256 }
{ MCI_SET_DOOR_CLOSED = 512 }
mciSendCommand(mci.wDeviceID, mci_Close, 0, 0);
end;
To open or close the CDROM, call OpenCloseCDDrive() passing one of the TCDAction types. This function will work on all types of CDs and will also work if there is no CDROM in the drive. This is similar to OpenCloseCD() except that this one requires a drive letter.
uses MMSystem, MPlayer;
type
TCDAction
= (_OPEN, _CLOSE);
function
OpenCloseCDDrive(Drive: Char; Action: TCDAction): boolean;
{
func to eject or close the cdrom drive. Works on all Audio &
}
{
Data CDs, even if there is no CDROM in the drive.
}
var
mp :
TMediaPlayer;
mciResult:
integer;
begin
Result :=
False;
Application.ProcessMessages;
if
not IsDriveCD(Drive) then
begin
MessageDlg(Drive + ':\ is not a CDROM drive.', mtError, [mbOK], 0);
Exit;
end;
Screen.Cursor
:= crHourGlass;
mp :=
TMediaPlayer.Create(nil);
try
mp.Visible := False;
mp.Parent := Application.MainForm;
mp.Shareable := True;
mp.DeviceType := dtCDAudio;
mp.FileName := Drive + ':';
mp.Open;
Application.ProcessMessages;
mciResult := 0;
case Action of
_OPEN : mp.Eject;
_CLOSE: mciResult := mciSendCommand(mp.DeviceID,
MCI_SET, MCI_SET_DOOR_CLOSED, 0);
end;
Application.ProcessMessages;
mp.Close;
Application.ProcessMessages;
case Action of
_OPEN : Result := True;
_CLOSE: Result := mciResult = 0;
end;
finally
mp.Free;
Screen.Cursor := crDefault;
end;
end;
To quickly empty the Recycle Bin, use this procedure. This will empty the Recycle Bin without any warnings or sounds.
procedure
EmptyRecycleBin;
{
proc to empty the recycle bin. }
const
SHERB_NOCONFIRMATION
= $00000001;
SHERB_NOPROGRESSUI
= $00000002;
SHERB_NOSOUND
= $00000004;
type
TSHEmptyRecycleBin = function (Wnd: HWND;
LPCTSTR: PChar;
DWORD: Word): integer; stdcall;
var
SHEmptyRecycleBin: TSHEmptyRecycleBin;
LibHandle:
THandle;
begin
LibHandle := LoadLibrary(PChar('Shell32.dll'));
if
LibHandle <> 0 then
@SHEmptyRecycleBin := GetProcAddress(LibHandle, 'SHEmptyRecycleBinA')
else
begin
MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);
Exit;
end;
if @SHEmptyRecycleBin
<> nil then
SHEmptyRecycleBin(Application.Handle,
'',
SHERB_NOCONFIRMATION or
SHERB_NOPROGRESSUI or
SHERB_NOSOUND);
FreeLibrary(LibHandle);
@SHEmptyRecycleBin
:= nil;
end;
Another commonly
asked question: How do I exit Windows? This procedure will
do the trick for you and it works on all 32-bit Windows platforms.
Note 1: This procedure uses GetWindowsVersion() provided on page 3 to read the Windows
version info.
Note 2: Be careful when trying this in the Delphi IDE, it WILL
restart or shutdown the computer! Save your work!
procedure ExitWindows32(ShutDownFlag:
Word);
{ proc
to Exit 32-bit Windows. ShutDownFlag is either EWX_REBOOT,
EWX_SHUTDOWN, or EWX_LOGOFF. }
function
ChangeNTSecurityForShutdown: Boolean;
{
This func changes security rights on a WinNT machine.
}
{
to give app shutdown privileges.
}
{
Use proc ExitWindows32 to reboot or shutdown the machine. }
var
hToken : THandle;
tkp,
Newt
: TTokenPrivileges;
retlength : DWORD;
begin
Result := False;
if
OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES +
TOKEN_QUERY, hToken) <> False then
begin
{ Get
the LUID for shutdown privilege }
if LookupPrivilegeValue( nil, 'SeShutdownPrivilege',
tkp.Privileges[0].Luid) = True then
begin
tkp.PrivilegeCount := 1; // One to set
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
{ Get shutdown privilege for this process }
Result := AdjustTokenPrivileges(hToken, False, tkp,
SizeOf(TTokenPrivileges), Newt,
retlength);
end;
end;
end;
begin
if
GetWindowsVersion = VER_PLATFORM_WIN32_NT then
begin
if ChangeNTSecurityForShutdown then
ExitWindowsEx(ShutDownFlag, 0)
else
{ Failed
to change security rights to give us shutdown privilege. }
MessageDlg('Unable to modify security rights for shutdown
privileges.', mtError, [mbOK], 0);
end
else
if
GetWindowsVersion = VER_PLATFORM_WIN32_WINDOWS then
ExitWindowsEx(ShutDownFlag, 0);
end;
This function, when passed a short path name, will convert it to a long 32-bit Windows style path name. For example: ExtractLongPathName('C:\Thisis~1\Thisis~1.txt') will return 'C:\This is a directory\This is a file.txt'. To extract the short path name, see ExtractShortPathName().
function
ExtractLongPathName(const PathName: string): string;
{
func to expand a Win3.1 style path name to a 32-bit Windows
naming convention. }
{
If file doesn't exist, func will return an empty string.
}
var
LastSlash,
PathPtr: PChar;
function
ExtractLongFileName(const FileName: string): string;
var
Info: TSHFileInfo;
begin
if SHGetFileInfo(PChar(FileName), 0, Info, Sizeof(Info),
SHGFI_DISPLAYNAME) <> 0 then
Result := string(Info.szDisplayName)
else
Result := FileName;
end;
begin
Result :=
'';
PathPtr :=
PChar(PathName);
LastSlash
:= StrRScan(PathPtr, '\');
while
LastSlash <> nil do
begin
Result := '\' + ExtractLongFileName(PathPtr) + Result;
if LastSlash <> nil then
begin
LastSlash^ := #0;
LastSlash := StrRScan(PathPtr, '\');
end;
end;
Result :=
PathPtr + Result;
end;
-- End of Page 1 --