Вопрос:
Как программно выключить монитор?
Ответ:
Программно можно отключить монитор совместимый со стандартом EnergyStar.
Отправьте сообщение wm_SysCommand с параметром WParam = SC_MonitorPower
и LParam = 0 для отключения монитора
LParam = 1 для включения монитора
В приведенном примере монитор отключается на 10 секунд.
Пример:
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
MonitorOff : bool;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Enabled := false;
Timer1.Interval := 10000;
MonitorOff := false;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if MonitorOff then begin
MonitorOff := false;
SendMessage(Application.Handle,
wm_SysCommand,
SC_MonitorPower,
-1);
Timer1.Enabled := false;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MonitorOff := true;
Timer1.Enabled := true;
SendMessage(Application.Handle,
wm_SysCommand,
SC_MonitorPower,
0);
end;
Наверх к содержанию
Вопрос:
Как создать мигающий заголовок окна (пиктограмму)?
Ответ:
Можно воспользоваться функцией API FlashWindow():
Пример:
var
Flash : bool;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
FlashWindow(Form1.Handle, Flash);
FlashWindow(Application.Handle, Flash);
Flash := not Flash;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Flash := False;
end;
Наверх к содержанию
Вопрос:
Иногда всплывающее меню моего приложения system tray не исчезает когда оно теряет
фокус. Как закрыть его?
Ответ:
При показе всплывающего меню установите foreground window, затем пошлите сообщение
WM_NULL после показа меню.
procedure TForm1.WndProc(var Msg : TMessage);
var
p : TPoint;
begin
case Msg.Msg of
WM_USER + 1:
case Msg.lParam of
WM_RBUTTONDOWN: begin
SetForegroundWindow(Handle);
GetCursorPos(p);
PopupMenu1.Popup(p.x, p.y);
PostMessage(Handle, WM_NULL, 0, 0);
end;
end;
end;
inherited;
end;
Наверх к содержанию
Вопрос:
Как узнать текущие время и дату по Гринвичу
Ответ:
Используя API фукцию GetSystemTime.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
lt : TSYSTEMTIME;
st : TSYSTEMTIME;
begin
GetLocalTime(lt);
GetSystemTime(st);
Memo1.Lines.Add('LocalTime = ' +
IntToStr(lt.wmonth) + '/' +
IntToStr(lt.wDay) + '/' +
IntToStr(lt.wYear) + ' ' +
IntToStr(lt.wHour) + ':' +
IntToStr(lt.wMinute) + ':' +
IntToStr(lt.wSecond));
Memo1.Lines.Add('UTCTime = ' +
IntToStr(st.wmonth) + '/' +
IntToStr(st.wDay) + '/' +
IntToStr(st.wYear) + ' ' +
IntToStr(st.wHour) + ':' +
IntToStr(st.wMinute) + ':' +
IntToStr(st.wSecond));
end;
Наверх к содержанию
Вопрос:
Какой самый быстрый способ для очистки canvasа?
Ответ:
Windows API функция PatBlt().
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
PatBlt(Form1.Canvas.Handle,
0,
0,
Form1.ClientWidth,
Form1.ClientHeight,
WHITENESS);
end;
Наверх к содержанию
Вопрос:
При изменении размеров формы мне необходимо чтобы перерисовывалась вся ее поверхность.
Но свойство Canvas.ClipRect у формы - только для чтения.
Ответ:
На событии Resize вызовите Windows API функцию InvalidateRect(). Если передать
nil в качестве второго параметра приведет к тому, что перерисовываться будет вся
клиентская область окна. Третий параметр указывает будет ли перерисовываться фон
формы.
Пример:
procedure TForm1.FormResize(Sender: TObject);
begin
InvalidateRect(Form1.Handle, nil, false);
end;
Наверх к содержанию
Вопрос:
Как использовать процедуру mouse_event() для имитации событий мыши?
Ответ:
Приведенный пример демонстрирует использование API функции mouse_event() для имитации
событий мыши. При нажатии кнопки Button2 программа перемещает курсор мыши на кнопку
Button1 и щелкает по ней. Положение курсора мыши задается в "абсолютных" координатах
("Mickeys"), где 65535 "Mickeys" равно ширине экрана.
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Button 1 clicked');
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Pt : TPoint;
begin
{Позволим кнопке Button2 перерисоваться}
Application.ProcessMessages;
{Найдем координаты центра button 1}
Pt.x := Button1.Left + (Button1.Width div 2);
Pt.y := Button1.Top + (Button1.Height div 2);
{Преобразуем Pt к координатам экрана}
Pt := ClientToScreen(Pt);
{Преобразуем Pt к "mickeys" (аболютным координатам курсора мышки}
Pt.x := Round(Pt.x * (65535 / Screen.Width));
Pt.y := Round(Pt.y * (65535 / Screen.Height));
{Переместим курсор мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_MOVE,
Pt.x,
Pt.y,
0,
0);
{Имитируем нажатие левой кнопки мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTDOWN,
Pt.x,
Pt.y,
0,
0);;
{Имитируем отпускание левой кнопки мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTUP,
Pt.x,
Pt.y,
0,
0);;
end;
Наверх к содержанию
Вопрос:
Как программно закрыть другое приложение?
Ответ:
Отправьте этому приложению сообщение WM_QUIT
Пример:
PostMessage(FindWindow(Nil, 'Заголовок окна'), WM_QUIT, 0, 0);
Где "Заголовок окна" - заголовок окна, которому Вы посылаете сообщение.
Наверх к содержанию
Вопрос:
Форматирование диска в Win32
Ответ:
ShellAPI функция ShFormatDrive().
Пример:
const SHFMT_DRV_A = 0;
const SHFMT_DRV_B = 1;
const SHFMT_ID_DEFAULT = $FFFF;
const SHFMT_OPT_QUICKFORMAT = 0;
const SHFMT_OPT_FULLFORMAT = 1;
const SHFMT_OPT_SYSONLY = 2;
const SHFMT_ERROR = -1;
const SHFMT_CANCEL = -2;
const SHFMT_NOFORMAT = -3;
function SHFormatDrive(hWnd : HWND;
Drive : Word;
fmtID : Word;
Options : Word) : Longint
stdcall; external 'Shell32.dll' name 'SHFormatDrive';
procedure TForm1.Button1Click(Sender: TObject);
var
FmtRes : longint;
begin
try
FmtRes:= ShFormatDrive(Handle,
SHFMT_DRV_A,
SHFMT_ID_DEFAULT,
SHFMT_OPT_QUICKFORMAT);
case FmtRes of
SHFMT_ERROR : ShowMessage('Error formatting the drive');
SHFMT_CANCEL :
ShowMessage('User canceled formatting the drive');
SHFMT_NOFORMAT : ShowMessage('No Format')
else
ShowMessage('Disk has been formatted');
end;
except
end;
end;
Наверх к содержанию
Вопрос:
Как спрятать и отключить кнопку "Пуск"?
Ответ:
Приведенный пример прячет и показывает кнопку "Пуск", а также разрешает и запрещает
ее.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
Rgn : hRgn;
begin
{Cпрятать кнопку "Пуск"}
Rgn := CreateRectRgn(0, 0, 0, 0);
SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
Rgn,
true);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
{Показать кнопку "Пуск"}
SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
0,
true);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
{Запретить кнопку "Пуск"}
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
false);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
{Разрешить кнопку "Пуск"}
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
true);
end
Наверх к содержанию
Вопрос:
Как временно отключить перерисовку окна?
Ответ:
Вызовите функцию WinAPI LockWindowUpdate передав ей дескриптор окна, которое необходимо
не обновлять. Передайте ноль в качестве параметра для восстановления нормального
обновления.
LockWindowUpdate(Memo1.Handle);
.
.
LockWindowUpdate(0);
Наверх к содержанию
Вопрос:
Моя программа использует дравер принтера. Возможно ли потихоньку установить драйвер
принтера без вмешательства пользователя?
Ответ:
Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать
файлы с драйвером принтера в каталог Windows\System и внести необходимые изменения
в файл Win.Ini.
Примечание:
DriverName = Имя драйвера;
DRVFILE - имя файла с драйвером без расширения
(".drv" - по умолчанию).
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
s : array[0..64] of char;
begin
WriteProfileString('PrinterPorts',
'DriverName',
'DRVFILE,FILE:,15,45');
WriteProfileString('Devices',
'DriverName',
'DRVFILE,FILE:');
StrCopy(S, 'PrinterPorts');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
StrCopy(S, 'Devices');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;
Наверх к содержанию
Вопрос:
Как набрать номер с помощью модема в Win32?
Ответ:
Используйте функцию Windows API CreateFile() чтобы получить дескриптор порта,
и стандартные функции ввода-вывода для связи с полученным портом.
Пример:
var
hCommFile : THandle;
procedure TForm1.Button1Click(Sender: TObject);
var
PhoneNumber : string;
CommPort : string;
NumberWritten : LongInt;
begin
PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10;
CommPort := 'COM2';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile=INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
{Dial the phone}
NumberWritten:=0;
if WriteFile(hCommFile,
PChar(PhoneNumber)^,
Length(PhoneNumber),
NumberWritten,
nil) = false then begin
ShowMessage('Unable to write to ' + CommPort);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
{Close the port}
CloseHandle(hCommFile);
end;
Наверх к содержанию
Вопрос:
Как использовать TAPI для голосового звонка?
Ответ:
См пример.
Пример:
{tapi Errors}
const TAPIERR_CONNECTED = 0;
const TAPIERR_DROPPED = -1;
const TAPIERR_NOREQUESTRECIPIENT = -2;
const TAPIERR_REQUESTQUEUEFULL = -3;
const TAPIERR_INVALDESTADDRESS = -4;
const TAPIERR_INVALWINDOWHANDLE = -5;
const TAPIERR_INVALDEVICECLASS = -6;
const TAPIERR_INVALDEVICEID = -7;
const TAPIERR_DEVICECLASSUNAVAIL = -8;
const TAPIERR_DEVICEIDUNAVAIL = -9;
const TAPIERR_DEVICEINUSE = -10;
const TAPIERR_DESTBUSY = -11;
const TAPIERR_DESTNOANSWER = -12;
const TAPIERR_DESTUNAVAIL = -13;
const TAPIERR_UNKNOWNWINHANDLE = -14;
const TAPIERR_UNKNOWNREQUESTID = -15;
const TAPIERR_REQUESTFAILED = -16;
const TAPIERR_REQUESTCANCELLED = -17;
const TAPIERR_INVALPOINTER = -18;
{tapi size constants}
const TAPIMAXDESTADDRESSSIZE = 80;
const TAPIMAXAPPNAMESIZE = 40;
const TAPIMAXCALLEDPARTYSIZE = 40;
const TAPIMAXCOMMENTSIZE = 80;
const TAPIMAXDEVICECLASSSIZE = 40;
const TAPIMAXDEVICEIDSIZE = 40;
function tapiRequestMakeCallA(DestAddress : PAnsiChar;
AppName : PAnsiChar;
CalledParty : PAnsiChar;
Comment : PAnsiChar) : LongInt;
stdcall; external 'TAPI32.DLL';
function tapiRequestMakeCallW(DestAddress : PWideChar;
AppName : PWideChar;
CalledParty : PWideChar;
Comment : PWideChar) : LongInt;
stdcall; external 'TAPI32.DLL';
function tapiRequestMakeCall(DestAddress : PChar;
AppName : PChar;
CalledParty : PChar;
Comment : PChar) : LongInt;
stdcall; external 'TAPI32.DLL';
procedure TForm1.Button1Click(Sender: TObject);
var
DestAddress : string;
CalledParty : string;
Comment : string;
begin
DestAddress := '1-555-555-1212';
CalledParty := 'Frank Borland';
Comment := 'Calling Frank';
tapiRequestMakeCall(pChar(DestAddress),
PChar(Application.Title),
pChar(CalledParty),
PChar(Comment));
end;
end.
Наверх к содержанию
Вопрос:
Как показать иконку, ассоциированной с данным типом файла?
Ответ:
ShellApi функция ExtractAssociatedIcon()
Пример:
uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
var
Icon : hIcon;
IconIndex : word;
begin
IconIndex := 1;
Icon := ExtractAssociatedIcon(HInstance,
Application.ExeName,
IconIndex);
DrawIcon(Canvas.Handle, 10, 10, Icon);
end;
Наверх к содержанию
Вопрос:
Как определение нажатия определенной клавиши во время загрузки приложения?
Ответ:
Используйту WinAPI функцию GetKeyState() для определения нажатия клавиши в тексте
проекта. Для того чтобы увидеть текст файла проекта в главном меню Delphi 3 выберите
"View">>"ProjectSource" в Delphi 4 "Project">>"View Source".
Пример:
program Project1;
uses
Windows,
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
begin
if GetKeyState(vk_F8) < 1 then
MessageBox(0, 'F8 was pressed during startup', 'MyApp', mb_ok);
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Наверх к содержанию
Вопрос:
Как заставить пикнуть динамик несколько раз с небольшой задержкой между сигналами,
не зависящей от тактовой частоты процессора?
Ответ:
См. пример.
Пример:
procedure Delay(ms : longint);
{$IFNDEF WIN32}
var
TheTime : LongInt;
{$ENDIF}
begin
{$IFDEF WIN32}
Sleep(ms);
{$ELSE}
TheTime := GetTickCount + ms;
while GetTickCount < TheTime do
Application.ProcessMessages;
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MessageBeep(word(-1));
Delay(200);
MessageBeep(word(-1));
Delay(200);
MessageBeep(word(-1));
end;
Наверх к содержанию
Вопрос:
Можно ли отключить кнопку закрытия любого окна?
Ответ:
Да, приведенный пример отключает кнопку закрытия и пункт "закрыть" ситсемного
меню заданного окна.
procedure TForm1.Button1Click(Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMENU;
begin
hwndHandle := FindWindow(nil, 'Untitled - Notepad');
if (hwndHandle <> 0) then begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;
Наверх к содержанию
Вопрос:
Как узнать путь к каталогам Windows?
Ответ:
Следующий пример получает полный список каталогов по умолчанию (Favorites, Desktop,
Programs, Fonts, SendTo, Start, Menu, Templates, Startup, Recent and NetHood)
Windows и заносит его в Memo.
Пример:
uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
reg : TRegistry;
ts : TStrings;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;
reg.LazyWrite := false;
reg.OpenKey(
'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',
false);
ts := TStringList.Create;
reg.GetValueNames(ts);
for i := 0 to ts.Count -1 do begin
Memo1.Lines.Add(ts.Strings[i] +
' = ' +
reg.ReadString(ts.Strings[i]));
end;
ts.Free;
reg.CloseKey;
reg.free;
end;
Наверх к содержанию
Вопрос:
Как узнать полный путь и имя файла загруженной DLL?
Ответ:
См. пример
Пример:
uses Windows;
procedure ShowDllPath stdcall;
var
TheFileName : array[0..MAX_PATH] of char;
begin
FillChar(TheFileName, sizeof(TheFileName), #0);
GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName));
MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok);
end;
Наверх к содержанию
Вопрос:
Как вызвать диалог 'Найти файлы и паки' проводника?
Ответ:
Приведенный пример показывает использование DDE для вызова диалога 'Найти файлы
и паки' Explorerа. Диалог открывается на каталоге "C:\Download".
procedure TForm1.Button1Click(Sender: TObject);
begin
with TDDEClientConv.Create(Self) do begin
ConnectMode := ddeManual;
ServiceApplication := 'explorer.exe';
SetLink( 'Folders', 'AppProperties');
OpenLink;
ExecuteMacro('[FindFolder(, C:\DOWNLOAD)]', False);
CloseLink;
Free;
end;
end;
Наверх к содержанию
Вопрос:
Как сделать родительское окно с фоновым рисунком в клиентской области?
Ответ:
Для того чтобы сделать это выполните следующие шаги:
Срздайте новый проект.
Установите FormStyle формы в fsMDIForm
Разместите Image на форме и загрузите в него картинку.
Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки:
FClientInstance : TFarProc;
FPrevClientProc : TFarProc;
procedure ClientWndProc(var Message: TMessage);
Добаьте следующие строки в разделе implementation:
procedure TMainForm.ClientWndProc(var Message: TMessage);
var
Dc : hDC;
Row : Integer;
Col : Integer;
begin
with Message do
case Msg of
WM_ERASEBKGND:
begin
Dc := TWMEraseBkGnd(Message).Dc;
for Row := 0 to ClientHeight div Image1.Picture.Height do
for Col := 0 to ClientWidth div Image1.Picture.Width do
BitBlt(Dc,
Col * Image1.Picture.Width,
Row * Image1.Picture.Height,
Image1.Picture.Width,
Image1.Picture.Height,
Image1.Picture.Bitmap.Canvas.Handle,
0,
0,
SRCCOPY);
Result := 1;
end;
else
Result := CallWindowProc(FPrevClientProc,
ClientHandle,
Msg,
wParam,
lParam);
end;
end;
В методе формы OnCreate добавьте:
FClientInstance := MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle,
GWL_WNDPROC));
SetWindowLong(ClientHandle,
GWL_WNDPROC, LongInt(FClientInstance));
Добавьте к проекту новую форму и установите ее свойство FormStyle в
fsMDIChild.
У Вас получился MDI-проект с "обоями" в клиентской области MDI формы.
Наверх к содержанию
Вопрос:
Как глобально перехватить нажатие кнопки PrintScreen?
Ответ:
В примере для глобального перехвата нажатия клавиши printscreen регистрируется
горячая клавиша (hot key).
Пример:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const id_SnapShot = 101;
procedure TForm1.WMHotKey (var Msg : TWMHotKey);
begin
if Msg.HotKey = id_SnapShot then
ShowMessage('GotIt');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterHotKey(Form1.Handle,
id_SnapShot,
0,
VK_SNAPSHOT);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey (Form1.Handle, id_SnapShot);
end;
Наверх к содержанию
Вопрос:
Существует ли способ для определение числа заданий spoolerа печати?
Ответ:
Spoolerа печати Windows посылает WM_SPOOLERSTATUS каждый раз при добавлении и
удалении заданий в очереди печати. В следующем примере показано как перехватить
это сообщение
Пример:
type
TForm1 = class(TForm)
Label1: TLabel;
private
{ Private declarations }
procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS);
message WM_SPOOLERSTATUS;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS);
begin
Lable1.Caption := IntToStr(msg.JobsLeft) +
' Jobs currenly in spooler';
msg.Result := 0;
end;
Наверх к содержанию
Вопрос:
Как определить имена установленых Com-портов?
Ответ:
Из реестра. См. пример.
Пример:
uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
reg : TRegistry;
ts : TStrings;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('hardware\devicemap\serialcomm',
false);
ts := TStringList.Create;
reg.GetValueNames(ts);
for i := 0 to ts.Count -1 do begin
Memo1.Lines.Add(reg.ReadString(ts.Strings[i]));
end;
ts.Free;
reg.CloseKey;
reg.free;
end;
Наверх к содержанию
Вопрос:
Извлечение пиктограммы из exe, dll или ico-файла
Ответ:
Функция SHELLAPI ExtractIconEx:
Обратите внимание - в примере функции обьявленны иначе, чем в модуле ShellAPI
type ThIconArray = array[0..0] of hIcon;
type PhIconArray = ^ThIconArray;
function ExtractIconExA(lpszFile: PAnsiChar;
nIconIndex: Integer;
phiconLarge : PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExA';
function ExtractIconExW(lpszFile: PWideChar;
nIconIndex: Integer;
phiconLarge: PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExW';
function ExtractIconEx(lpszFile: PAnsiChar;
nIconIndex: Integer;
phiconLarge : PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExA';
procedure TForm1.Button1Click(Sender: TObject);
var
NumIcons : integer;
pTheLargeIcons : phIconArray;
pTheSmallIcons : phIconArray;
LargeIconWidth : integer;
SmallIconWidth : integer;
SmallIconHeight : integer;
i : integer;
TheIcon : TIcon;
TheBitmap : TBitmap;
begin
NumIcons :=
ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe',
-1,
nil,
nil,
0);
if NumIcons > 0 then begin
LargeIconWidth := GetSystemMetrics(SM_CXICON);
SmallIconWidth := GetSystemMetrics(SM_CXSMICON);
SmallIconHeight := GetSystemMetrics(SM_CYSMICON);
GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0);
FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0);
ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe',
0,
pTheLargeIcons,
pTheSmallIcons,
numIcons);
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}
for i := 0 to (NumIcons - 1) do begin
DrawIcon(Form1.Canvas.Handle,
i * LargeIconWidth,
0,
pTheLargeIcons^[i]);
TheIcon := TIcon. Create;
TheBitmap := TBitmap.Create;
TheIcon.Handle := pTheSmallIcons^[i];
TheBitmap.Width := TheIcon.Width;
TheBitmap.Height := TheIcon.Height;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
TheIcon.Free;
Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth,
100,
(i + 1) * SmallIconWidth,
100 + SmallIconHeight),
TheBitmap);
TheBitmap.Free;
end;
{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
end;
end;
end.
Наверх к содержанию
Вопрос:
как заставить Рабочий Стола Windows обновится?
Ответ:
См. пример.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(FindWindow('Progman', 'Program Manager'),
WM_COMMAND,
$A065,
0);
end;
Наверх к содержанию
Вопрос:
Перерисовка canvasf моей формы занимает довольно много времени. Как определить
установлен ли у пользователя режим перерисовки всего окна при перемещении чтобы
временно отключить перерисовку моего окна?
Ответ:
В приведенном примере определяется включен ли режим "Full Window Drag" (перерисовки
всего окна при перемещении)
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
b : bool;
begin
SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @b, 0);
if not b then
ShowMessage('Full Window Drag is not enabled') else
ShowMessage('Full Window Drag is enabled');
end;
Наверх к содержанию
Вопрос:
Как уступить выделенный моей программе квант процессорного времени другим приложениям?
Ответ:
Вызовите функцию Windows API Sleep() передав ноль в качестве параметра.
Наверх к содержанию
Вопрос:
Как запускать мою программу на каждом старте Windows?
Ответ:
Пример работает и для Win32и для Win16.
uses
Registry, {For Win32}
IniFiles; {For Win16}
{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}
{For Win32}
procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run',
false);
reg.WriteString('My App', Application.ExeName);
reg.CloseKey;
reg.free;
end;
{For Win16}
procedure TForm1.Button2Click(Sender: TObject);
var
WinIni : TIniFile;
WinIniFileName : array[0..MAX_PATH] of char;
s : string;
begin
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('windows',
'run',
'');
if s = '' then
s := Application.ExeName else
s := s + ';' + Application.ExeName;
WinIni.WriteString('windows',
'run',
s);
WinIni.Free;
end;
Наверх к содержанию