function SetPrivilege(aPrivilegeName : string;
aEnabled : boolean ): boolean;
var
TPPrev,
TP : TTokenPrivileges;
Token : THandle;
dwRetLen : DWord;
begin
Result := False;
OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES
or TOKEN_QUERY, @Token );
TP.PrivilegeCount := 1;
if( LookupPrivilegeValue(nil, PChar( aPrivilegeName ),
TP.Privileges[ 0 ].LUID ) ) then
begin
if( aEnabled )then
TP.Privileges[0].Attributes:= SE_PRIVILEGE_ENABLED;
else
TP.Privileges[0].Attributes:= 0;
dwRetLen := 0;
Result := AdjustTokenPrivileges(Token,False,TP,
SizeOf( TPPrev ),
TPPrev,dwRetLen );
end;
CloseHandle( Token );
end;
function WinExit( iFlags : integer ) : boolean;
// possible Flags:
// EWX_LOGOFF
// EWX_REBOOT
// EWX_SHUTDOWN
begin
Result := True;
if( SetPrivilege( 'SeShutdownPrivilege', true ) ) then
begin
if( not ExitWindowsEx( iFlags, 0 ) )then
begin
Result := False;
end;
SetPrivilege( 'SeShutdownPrivilege', False )
end
else
begin
Result := False;
end;
end;
{ define Global vars }
var
Form1: TForm1;
StartButton: hWnd;
OldBitmap: THandle;
NewImage: TPicture;
{ put the Code in the OnCreate event of your form }
procedure TForm1.FormCreate(Sender: TObject);
begin
NewImage := TPicture.create;
NewImage.LoadFromFile('C:\Windows\Circles.BMP');
StartButton := FindWindowEx
(FindWindow(
'Shell_TrayWnd', nil),
0,'Button', nil);
OldBitmap := SendMessage(StartButton,
BM_SetImage, 0,
NewImage.Bitmap.Handle);
end;
{ OnDestroy-Event }
procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(StartButton,BM_SetImage,0,OldBitmap);
NewImage.Free;
end;
This code demonstrates use of windows registery and function overloading to read from registery:
if key doesnt exist it's created and Default passed to key value ReadReg(KeyToRead,DefaultValue)
to write to registery:
writereg(KeyToWrite,ValueToKey)
Supports integer,string and boolean types, other type can be similary added.}
unit module1;
interface
uses Windows, registry;
function WriteReg(Key:string;value:integer) :boolean; overload;
function WriteReg(Key:string;value:boolean) :boolean; overload;
function WriteReg(Key:string;value:String) :boolean; overload;
function ReadReg(Key:string;default:String='') :string; overload;
function ReadReg(Key:string;default:integer=0) :integer; overload;
function ReadReg(Key:string;default:boolean=false):boolean;overload;
const
ApplicationName:string ='MyProgram'; //Your Programname
implementation
function ReadReg(Key:string;default:integer=0):integer;
var
Registry: TRegistry;
begin
Registry :=TRegistry.Create;
Registry.RootKey :=HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ ApplicationName,True);
if registry.ValueExists(key) =true then
result:=Registry.readinteger(key)
else
begin
Registry.Writeinteger(key,default);
result:=Registry.readinteger(key);
end;
Registry.Free;
end;
function ReadReg(Key:string;default:string=''):string;
var
Registry : TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey :=HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
if registry.ValueExists(key) then
readreg := Registry.readstring(key)
else
begin
Registry.Writestring(key,default);
Readreg := Registry.readstring(key);
end;
Registry.Free;
end;
function ReadReg(Key:string;default:boolean=false):boolean;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
if registry.ValueExists(key) then
readreg:=Registry.readbool(key)
else
begin
Registry.Writebool(key,default);
readreg:=Registry.readbool(key);
end;
Registry.Free;
end;
function WriteReg(Key:string;value:boolean):boolean;
var Registry: TRegistry;
begin
Registry:=TRegistry.Create;
Registry.RootKey:=HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
registry.WriteBool(key,value);
result:= registry.KeyExists(key);
Registry.Free;
end;
function WriteReg(Key:string;value:string):boolean;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
registry.Writestring(key,value);
result:= registry.KeyExists(key);
Registry.Free;
end;
function WriteReg(Key:string;value:integer):boolean;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
registry.Writeinteger(key,value);
writereg:= registry.KeyExists(key);
Registry.Free;
end;
Compare dates
Uses SysUtils;
...
if(Date < EncodeDate( 2000, 1, 1 )) then
Showmessage(' The date is ' + DateToStr(Date));
…
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject); protected
procedure WMDROPFILES (var Msg: TMessage); message WM_DROPFILES;
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
uses shellapi;
{$R *.DFM}
procedure TForm1.WMDROPFILES (var Msg: TMessage);
var i,anzahl, size : integer;
Dateiname : PChar;
begin
inherited;
anzahl := DragQueryFile(Msg.WParam, $FFFFFFFF,Dateiname,255);
for i := 0 to (anzahl - 1) do
begin
size := DragQueryFile(Msg.WParam, i , nil, 0) + 1;
Dateiname:= StrAlloc(size);
DragQueryFile(Msg.WParam,i , Dateiname, size);
listbox1.items.add(StrPas(Dateiname)); StrDispose(Dateiname);
end;
DragFinish(Msg.WParam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, true);
end;
end.
Found in the Win32.hlp
type
PTokenUser = ^TTokenUser;
_TOKEN_USER = record
User: TSIDAndAttributes;
end;
TTokenUser = _TOKEN_USER;
procedure getCurrentUserAndDomain(var User, Domain: String);
var
hProcess, hAccessToken: THandle;
InfoBuffer: array[0..1000] of Char;
szAccountName, szDomainName: array [0..200] of Char;
dwInfoBufferSize, dwAccountSize, dwDomainSize: DWORD;
pUser: PTokenUser;
snu: SID_NAME_USE;
begin
dwAccountSize:=200;
dwDomainSize:=200;
hProcess:=GetCurrentProcess;
OpenProcessToken(hProcess,TOKEN_READ,hAccessToken);
GetTokenInformation(hAccessToken,TokenUser,@InfoBuffer[0],1000,
dwInfoBufferSize);
pUser:=PTokenUser(@InfoBuffer[0]);
LookupAccountSid(nil, pUser.User.Sid, szAccountName, dwAccountSize, szDomainName, dwDomainSize, snu);
User:=szAccountName;
Domain:=szDomainName;
CloseHandle(hAccessToken);
end;
computer For Win95, you can find it in the registry - but this is not portable to NT. A safer way (and one which is portable to NT) would be to use the Win32 calls GetComputerName and GetUserName, both of which are defined in the Windows unit. Each of these functions takes a buffer as its first parameter and the length of the buffer as its second.
The function definitions are shown below:
function GetComputerName(lpBuffer:PChar;
var nSize:DWORD): BOOL; stdcall;
function GetUserName(lpBuffer :PChar;
var nSize: DWORD): BOOL; stdcall;
Use them like this:
function GetWindowsUserName : string;
const
cnMaxLen = 254;
var
sUserName : string;
dwUserNameLen : DWord;
begin
dwUserNameLen:=cnMaxLen-1;
SetLength(sUserName,cnMaxLen);
GetUserName(Pchar(sUserName),dwUserNameLen);
SetLength(sUserName,dwUserNameLen);
result:=sUserName;
if dwUserNameLen=cnMaxLen-1 then result:='';
end;
You may have noticed that using SystemParametersInfo to change the wallpaper when ActiveDesktop is turned on doesn't work. The reason is because you need to use the IActiveDesktop COM interface. Using SystemParametersInfo still works, but it doesn't update the wallpaper.
Note that the IActiveDesktop interface requires a Shell32.dll version >= 4.71. The document titled "Get a File Version" demonstrates how to check the file version and uses the shell32.dll as an example.
Here is an example of using IActiveDesktop to work with
the wallpaper. It assumes that you have 3 labels on a form
and two buttons with the default names.
uses
ComObj, // For CreateComObject and Initialization/Finalization of COM
ShlObj; // For IActiveDesktop
{ The CLASS ID for ActiveDesktop is not defined in ShlObj, while the IID is so we define it here. }
const
CLSID_ActiveDesktop : TGUID = '{75048700-EF1F11D0-9888-06097DEACF9}';
{ Demonstrate getting the Wallpaper }
procedure TForm1.Button1Click(Sender: TObject);
var
ActiveDesktop : IActiveDesktop;
CurrentWallpaper : string;
CurrentPattern : string;
WallpaperOptions : TWallpaperOpt;
TmpBuffer : PWideChar;
begin
// Create the ActiveDesktop COM Object
ActiveDesktop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
// We now need to allocate some memory to get the current Wallpaper.
// However, tmpBuffer is a PWideChar which means 2 bytes make
// up one Char. In order to compenstate for the WideChar, we
// allocate enough memory for MAX_PATH*2
tmpBuffer := AllocMem(MAX_PATH*2);
try
ActiveDesktop.GetWallpaper(tmpBuffer, MAX_PATH*2, 0);
CurrentWallpaper := tmpBuffer;
finally
FreeMem(tmpBuffer);
end;
if CurrentWallpaper <> '' then
Label1.Caption := 'Current Wallpaper: ' + CurrentWallpaper
else
Label1.Caption := 'No Wallpaper set';
// Now get the current Wallpaper options.
// The second parameter is reserved and must be 0.
WallpaperOptions.dwSize := SizeOf(WallpaperOptions);
ActiveDesktop.GetWallpaperOptions(WallpaperOptions, 0);
case WallpaperOptions.dwStyle of
WPSTYLE_CENTER : Label2.Caption := 'Centered';
WPSTYLE_TILE : Label2.Caption := 'Tiled';
WPSTYLE_STRETCH : Label2.Caption := 'Stretched';
WPSTYLE_MAX : Label2.Caption := 'Maxed';
end;
{Now get the desktop pattern. The pattern is a string of decimals whose bit pattern represents a picture. Each decimal represents the on/off state of the 8 pixels in that row. }
tmpBuffer := AllocMem(256);
try
ActiveDesktop.GetPattern(tmpBuffer, 256, 0);
CurrentPattern := tmpBuffer;
finally
FreeMem(tmpBuffer);
end;
if CurrentPattern <> '' then
Label3.Caption := CurrentPattern
else
Label3.Caption := 'No Pattern set';
end;
{ Demonstrate setting the wallpaper }
procedure TForm1.Button2Click(Sender: TObject);
var
ActiveDesktop: IActiveDesktop;
begin
ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
ActiveDesktop.SetWallpaper('c:\downloads\images\test.bmp', 0);
ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
end;
Responds:
Good programming. But I just calling
SystemParametersInfo( SPI_SETDESKWALLPAPER, 0, @WallpaperBMPFileAndPath[1], 3);





