Изменение шрифта у всплывающих подсказок
unit unit1;
interface
uses
sysutils, wintypes, winprocs, messages, classes, graphics, controls,
forms, dialogs, stdctrls;
type
tform1 = class(tform)
edit1: tedit;
procedure formcreate(sender: tobject);
private
{ private declarations }
public
{ public declarations }
end;
var
form1: tform1;
implementation
{$r *.dfm}
type
tmyhintwindow = class (thintwindow)
constructor create (aowner: tcomponent); override;
end;
constructor tmyhintwindow.create (aowner: tcomponent);
begin
inherited create (aowner);
canvas.font.name := 'times new roman';
canvas.font.size := 14;
end;
procedure tform1.formcreate(sender: tobject);
begin
application.showhint := false;
hintwindowclass := tmyhintwindow;
application.showhint := true;
end;
end.
Как проверить готовность диска a:\
function diskindrive(const drive: char): boolean;
var
drvnum: byte;
emode: word;
begin
result := true; // было false
drvnum := ord(drive);
if drvnum >= ord('a') then dec(drvnum,$20);
emode := seterrormode(sem_failcriticalerrors);
try
while disksize(drvnum-$40) = -1 do begin // при неудаче выводим
диалог
if (application.messagebox('Диск не готов...'+chr(13)+chr(10)+
'Повторить?',pchar('Диск '+uppercase(drive)),mb_okcancel+
mb_iconexclamation{iconquestion})=idcancel) then begin
result:=false;
break;
end;
end;
finally
seterrormode(emode);
end;
end;
Перекодировка текста
procedure wintodos;
var src, str:pchar;//src-строка для перевода str-конечная
begin
src := memo1.lines.gettext; //Берем текст из tmemo как тип pchar
chartooem(src, str); //api функция для перевода текста
memo2.lines.text := strpas(str);//Записываем назад
end;
procedure dostowin;
var src, str:pchar;
begin
src := memo1.lines.gettext; //Берем текст из tmemo как тип pchar
oemtochar(src, str); //api функция для перевода текста
memo2.lines.text := strpas(str);//Записываем назад
end;
Открытие и закрытие привода cd-rom
unit drivetools;
interface
uses
windows, sysutils, mmsystem;
function closecd(drive : char) : boolean;
function opencd(drive : char) : boolean;
implementation
function opencd(drive : char) : boolean;
var
res mcierror;
openparm: tmci_open_parms;
flags : dword;
s : string;
deviceid : word;
begin
result:=false;
s:=drive+':';
flags:=mci_open_type or mci_open_element;
with openparm do begin
dwcallback := 0;
lpstrdevicetype := 'cdaudio';
lpstrelementname := pchar(s);
end;
res := mcisendcommand(0, mci_open, flags, longint(@openparm));
if res<>0 then exit;
deviceid:=openparm.wdeviceid;
try
res:=mcisendcommand(deviceid, mci_set, mci_set_door_open, 0);
if res=0 then exit;
result:=true;
finally
mcisendcommand(deviceid, mci_close, flags, longint(@openparm));
end;
end;
function closecd(drive : char) : boolean;
var
res : mcierror;
openparm: tmci_open_parms;
flags : dword;
s : string;
deviceid : word;
begin
result:=false;
s:=drive+':';
flags:=mci_open_type or mci_open_element;
with openparm do begin
dwcallback := 0;
lpstrdevicetype := 'cdaudio';
lpstrelementname := pchar(s);
end;
res := mcisendcommand(0, mci_open, flags, longint(@openparm));
if res<>0 then exit;
deviceid:=openparm.wdeviceid;
try
res:=mcisendcommand(deviceid, mci_set, mci_set_door_closed, 0);
if res=0 then exit;
result:=true;
finally
mcisendcommand(deviceid, mci_close, flags, longint(@openparm));
end;
end;
end.
Как подавить реакцию на ctrl+alt+del?
В некоторых случаях (например, при работе в полноэкранном режиме, показе своей презентации или экранной заставки ...) бывает полезно заблокировать перечисленные комбинации клавиш. Они блокируются при работе системы в режиме "экранная заставка" , который в свою очередь несложно включить и выключить:
// Включение режима
systemparametersinfo(spi_screensaverrunning, 1, 0, 0);
// Выключение режима
systemparametersinfo(spi_screensaverrunning, 0, 0, 0);
Кстати, systemparametersinfo имеет еще кучу полезных ключей spi_****, подробности см. в win32.hlp
Как изменить изображение на кнопке ПУСК?
{ объявляем глобальные переменные }
var
form1: tform1;
startbutton: hwnd;
oldbitmap: thandle;
newimage: tpicture;
{ добавляем следующий код в событие формы oncreate }
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 }
procedure tform1.formdestroy(sender: tobject);
begin
sendmessage(startbutton,bm_setimage,0,oldbitmap);
newimage.free;
end;
Как изменить обои на рабочем столе?
program wallpapr;
uses registry, winprocs;
procedure setwallpaper(swallpaperbmppath:string;btile:boolean);
var
reg : treginifile;
begin
// Изменяем ключи реестра
// hkey_current_user
// control panel\desktop
// tilewallpaper (reg_sz)
// wallpaper (reg_sz)
reg := treginifile.create('control panel\desktop' );
with reg do begin
writestring( '', 'wallpaper',
swallpaperbmppath );
if( btile )then
begin
writestring('', 'tilewallpaper', '1' );
end else begin
writestring('', 'tilewallpaper', '0' );
end;
end;
reg.free;
// Оповещаем всех о том, что мы изменили системные настройки
systemparametersinfo(spi_setdeskwallpaper, 0, nil,
{Эта строка - продолжение предыдущей}spif_sendwininichange );
end;
// пример установки wallpaper по центру рабочего стола
setwallpaper('c:\winnt\winnt.bmp', false );
//Эту строчку надо написать где-то в программе.