Мир программирования - Delphi - WinAPI FAQ

Мир программирования

 


Найти: на:


Меню
Партнеры
Счетчики
Реклама

WinAPI FAQ


Программное выключение монитора.
Мигающий заголовок окна.
Закрытие всплывающего меню в приложении system tray.
Текущее время и дата по Гринвичу.
Способ быстрой очистки canvasа .
Использование InvalidateRect()t для перерисовки всей формы.
Использование процедуры mouse_event() .
Программное закрытие другого приложения.
Форматирование диска.
Отключение кнопки 'Пуск'.
Отключение обновления окна.
Программная установка драйвера принтера.
Как набрать номер с помощью модема в Win32.
Использование Tapi (Telephony API).
Показ иконки, ассоциированной с данным типом файла.
Определение нажатия определенной клавиши во время загрузки приложения.
Звуки из динамика.
Отключение кнопки закрытия любого окна.
Как узнать путь к каталогам Windows.
Как узнать полный путь и имя файла загруженной DLL.
Вызов диалога 'Найти файлы и паки' проводника.
MDI - родительское окно с фоновым рисунком.
Как перехватить нажатие кнопки PrintScreen в Windows.
Определение числа заданий spoolerа печати.
Как определить имена установленых Com-портов.
Извлечение пиктограммы из exe, dll или ico-файла.
Обновление Рабочего Стола Windows.
Отключение перерисовки содержимого окна при перемещении.
Передача процессорных циклов другим приложениям.
Запуск программы на старте Windows.
Увеличение процессорного времени, выделяемого программе.
Определение момента окончания изменения размера окна.
Определение времени последнего доступа к файлу.
Использование функции Shell API SHBrowseForFolder.
Получение дескриптора окна Window, сожержащего DOS программу.
Определение факта изменения системного времени.
Очистка пункта Документы меню кнопки Пуск .
Опеределение состояния модема под Win32.
Добавление пункта к системному меню.
Создание нестандартной процедуры разбиения слов.
Копирование файлов, используя стандартный диалог Копирование Файла Windows.
Как узнать серийный номер диска.
Как узнать тип диска.
Проверка готовности диска.
Использование FindFirst для поиска файлов.
Получение дескриптора окна другого приложения.
Создание не-VCL консольного поекта.
Ошибка внешней функции при передаче параметров типа boolean.
Как получить длинное имя файла .
Временное отключение range checking .
Получение имени файла и пути локальной таблицы.
Получение дескриптора панели задач (TaskBar).
Запуск Screen saver'а програмно.
Установлены ли TrueType шрифты.
Как послать файл в корзину.
Обои рабочего стола.
Запущен ли Delphi.
Версия Windows.
Переменные окружения DOS.
Рисовать на Рабочем столе.
Каталог Windows.
Размер Рабочего стола.
Как закрыть CD.
Определение свободного дискового пространства.
Как спрятать Windows Taskbar.
Машина в сети.
Добавить документ в меню ПУСК ДОКУМЕНТЫ.
Изменить порт принтера.
Определить измения оборудования PlugNPlay.
Изменения в ini-файле.
Как открыть Проводником кокретный каталог.
Запустить аплет панели управления.
Цветная печать.
Открыть URL установленным браузером.
Стереть ехе-файл во время выполнения.
Програмно добавить шрифты True Type.
Часовые пояса.
Использование функции GetTimeZoneInformation.
Прозрачный текст.
Информация о версии файла.
Как создать иконку из bitmap'а.
Преобразование цвета в оттенки серого.
Как держать приложение в минимизированном виде.
Вызов функции RegisterClass .
drag &drop файлов.
Создание задержки без таймера.
Перезапуск Windows.




Вопрос:
Как программно выключить монитор?

Ответ:
Программно можно отключить монитор совместимый со стандартом 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;

Наверх к содержанию

Вопрос :
Как увеличить процессорное время, выделяемого программе?
Ответ :
Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать с осторожностью - т.к. присвоение слишком высокого приоритета может привети к медленной работе остальных программ и системы в целом. См. Win32 help for SetThreadPriority() function.
Пример :

procedure TForm1.Button1Click(Sender: TObject);
var
ProcessID : DWORD;
ProcessHandle : THandle;
ThreadHandle : THandle;
begin
ProcessID := GetCurrentProcessID;
ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID);
SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
ThreadHandle := GetCurrentThread;
SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;

Наверх к содержанию

Вопрос :
Я хочу определить момент окончания изменения размера или перемещения окна. Перехватываю сообщения WM_SIZE и WM_MOVE но я получаю много таких сообщений а мне нужно узнать когда именно пользователь закончил перенос или изменение размеров окна. Возможно ли это?
Ответ :
В следующем примере показан перехват сообщения WM_EXITSIZEMOVE Хотя сообщение документированно только для Windows NT оно работает точно так же и под Windows 95. Обратите внимание что Вы можите перехватить сообщение WM_ENTERSIZEMOVEдля определения момента начала пользователем операции изменения размера или перемещения окна.
Пример :

type TForm1 = class(TForm)
private
{ Private declarations }
public
procedure WMEXITSIZEMOVE(var Message: TMessage);
message WM_EXITSIZEMOVE;
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage);
begin
Form1.Caption := 'Finished Moving and sizing';
end;

Наверх к содержанию

Вопрос :
Как определить время последнего доступа к файлу?
Ответ :
См пример. Примечание: не все файловые системы поддерживают время последнего доступа к файлу.
Пример :

procedure TForm1.Button1Click(Sender: TObject);
var
SearchRec : TSearchRec;
Success : integer;
DT : TFileTime;
ST : TSystemTime;
begin
Success := SysUtils.FindFirst('C:\autoexec.bat', faAnyFile, SearchRec);
if (Success = 0) and (( SearchRec.FindData.ftLastAccessTime.dwLowDateTime <> 0) or ( SearchRec.FindData.ftLastAccessTime.dwHighDateTime <> 0)) then
begin
FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT);
FileTimeToSystemTime(DT,ST);
Memo1.Lines.Clear;
Memo1.Lines.Add('AutoExec.Bat was last accessed at:');
Memo1.Lines.Add('Year := ' + IntToStr(st.wYear));
Memo1.Lines.Add('Month := ' + IntToStr(st.wMonth));
Memo1.Lines.Add('DayOfWeek := ' + IntToStr(st.wDayOfWeek));
Memo1.Lines.Add('Day := ' + IntToStr(st.wDay));
Memo1.Lines.Add('Hour := ' + IntToStr(st.wHour));
Memo1.Lines.Add('Minute := ' + IntToStr(st.wMinute));
Memo1.Lines.Add('Second := ' + IntToStr(st.wSecond));
Memo1.Lines.Add('Milliseconds := ' + IntToStr(st.wMilliseconds));
end;
SysUtils.FindClose(SearchRec);
end;

Наверх к содержанию

Вопрос :
Как использовать функцию Shell API SHBrowseForFolder чтобы позволить пользователю выбрать каталог?
Ответ :
См. пример
Пример :

uses ShellAPI, ShlObj;
procedure TForm1.Button1Click(Sender: TObject);
var
TitleName : string;
lpItemID : PItemIDList;
BrowseInfo : TBrowseInfo;
DisplayName : array[0..MAX_PATH] of char;
TempPath : array[0..MAX_PATH] of char;
begin
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
BrowseInfo.hwndOwner := Form1.Handle;
BrowseInfo.pszDisplayName := @DisplayName;
TitleName := 'Please specify a directory';
BrowseInfo.lpszTitle := PChar(TitleName);
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
lpItemID := SHBrowseForFolder(BrowseInfo);
if lpItemId <> nil then
begin
SHGetPathFromIDList(lpItemID, TempPath);
ShowMessage(TempPath);
GlobalFreePtr(lpItemID);
end;
end;

Наверх к содержанию

Вопрос :
Как получить дескриптора окна Window, сожержащего DOS программу или программу консольного режима?
Ответ :
В следуещем примере используется функция Windows API FindWindow(). Обратите внимание, что WndClass консольного окна отличаются для Windows 95 и Window NT и заголовок окна может содержать полный путь под Windows NT.
Пример :

procedure TForm1.Button1Click(Sender: TObject);
var info : TOSVersionInfo;
ClassName : string;
Title : string;
begin
{Проверяем - Win95 или NT.}
info.dwOSVersionInfoSize := sizeof(info);
GetVersionEx(info);
if (info.dwPlatformId = VER_PLATFORM_WIN32_NT) then
begin
ClassName := 'ConsoleWindowClass';
Title := 'Command Prompt';
end else
begin
ClassName := 'tty';
Title := 'MS-DOS Prompt';
end;
ShowMessage(IntToStr(FindWindow(PChar(ClassName), PChar(Title))));
end;

Наверх к содержанию

Вопрос :
Возможно ли определить факта изменения системного времени другим приложением?
Ответ :
Следующий прмер перехватывает событие WM_TIMECHANGE. примечание: Приложение , изменяющее системное время должно посылать сообщение WM_TIMECHANGE всем окнам.

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMTIMECHANGE(var Message: TWMTIMECHANGE);
message WM_TIMECHANGE;
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE);
begin
Form1.Caption := 'Time Changed';
end;

Наверх к содержанию

Вопрос :
Как очистить пункт документы меню кнопки Пуск
Ответ :
Вызовите Windows API функцию SHAddToRecentDocs() передав nil вместо имени файла в качестве параметра.
Пример :

uses ShlOBJ;
procedure TForm1.Button1Click(Sender: TObject);
begin
SHAddToRecentDocs(SHARD_PATH, nil);
end;

Наверх к содержанию

Вопрос :
Как опеределить состояние модема под Win32?
Ответ :
См. пример
Пример :

procedure TForm1.Button1Click(Sender: TObject);
var
CommPort : string;
hCommFile : THandle;
ModemStat : DWord;
begin
CommPort := 'COM2';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort), GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
{Get the Modem Status}
if GetCommModemStatus(hCommFile, ModemStat) <> false then
begin
if ModemStat and MS_CTS_ON <> 0 then
ShowMessage('The CTS (clear-to-send) is on.');
if ModemStat and MS_DSR_ON <> 0 then
ShowMessage('The DSR (data-set-ready) is on.');
if ModemStat and MS_RING_ON <> 0 then
ShowMessage('The ring indicator is on.');
if ModemStat and MS_RLSD_ON <> 0 then
ShowMessage('The RLSD (receive-line-signal-detect) is on.');
end;
{Close the comm port}
CloseHandle(hCommFile);
end;

Наверх к содержанию

Вопрос :
Как добавить пункт к системному меню приложения?
Пример :

type TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure WMSysCommand(var Msg: TWMSysCommand);
message WM_SYSCOMMAND;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const SC_MyMenuItem = WM_USER + 1;
procedure TForm1.FormCreate(Sender: TObject);
begin
AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, '');
AppendMenu(GetSystemMenu(Handle, FALSE), MF_STRING, SC_MyMenuItem, 'My Menu Item');
end;
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if Msg.CmdType = SC_MyMenuItem then
ShowMessage('Got the message') else inherited;
end;

Наверх к содержанию

Вопрос :
Как создание нестандартную процедуру разбиения слов при переносах для TEdit, TMemo или TRichEdit?
Ответ :
В следующем примере создается процедура разбиения слов при переносах для TMemo. Заметьте, что реализованная процедура просто всегда разрешает перенос. Для дополнительной информации см.таже документацию к сообщению EM_SETWORDBREAKPROC.

var
OriginalWordBreakProc : pointer;
NewWordBreakProc : pointer;
function MyWordBreakProc(LPTSTR : pchar; ichCurrent : integer; cch : integer; code : integer) : integer
{$IFDEF WIN32}
stdcall;
{$ELSE} ;
export;
{$ENDIF}
begin
result := 0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OriginalWordBreakProc := Pointer( SendMessage(Memo1.Handle, EM_GETWORDBREAKPROC, 0, 0));
{$IFDEF WIN32}
NewWordBreakProc := @MyWordBreakProc;
{$ELSE}
NewWordBreakProc := MakeProcInstance(@MyWordBreakProc, hInstance);
{$ENDIF}
SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(NewWordBreakProc));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(@OriginalWordBreakProc));
{$IFNDEF WIN32}
FreeProcInstance(NewWordBreakProc);
{$ENDIF}
end;

Наверх к содержанию

Вопрос :
Можно ли скопировать группу файлов, используя стандартный диалог с анимацией Копирование Файлов, который использует "Проводник" (Explorer)?
Ответ :
В следующем примере используется функция SHFileOperation для копирования группы файлов и показа анимированного диалога. Вы можете использовать также следующие флаги для копирования, удаления, переноса и переименования файлов.

TO_COPY FO_DELETE FO_MOVE FO_RENAME

Примечание: буфер, содержащий имена файлов для копирования должен заканчиваться двумя нулевыми символами.
Пример :

uses ShellAPI;
procedure TForm1.Button1Click(Sender: TObject);
var
Fo : TSHFileOpStruct;
buffer : array[0..4096] of char;
p : pchar;
begin
FillChar(Buffer, sizeof(Buffer), #0);
p := @buffer;
p := StrECopy(p, 'C:\DownLoad\1.ZIP') + 1;
p := StrECopy(p, 'C:\DownLoad\2.ZIP') + 1;
p := StrECopy(p, 'C:\DownLoad\3.ZIP') + 1;
StrECopy(p, 'C:\DownLoad\4.ZIP');
FillChar(Fo, sizeof(Fo), #0);
Fo.Wnd := Handle;
Fo.wFunc := FO_COPY;
Fo.pFrom := @Buffer;
Fo.pTo := 'D:\';
Fo.fFlags := 0;
if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then
ShowMessage('Cancelled')
end;

Наверх к содержанию

Вопрос :
Как узнать серийный номер диска
Ответ :

procedure TForm1.Button1Click(Sender: TObject);
var
VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord;
MaxComponentLength, FileSystemFlags : Integer;
begin
GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo, MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH);
Memo1.Lines.Add('VName = '+VolumeName);
Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
Memo1.Lines.Add('FSName = '+FileSystemName);
end;

Наверх к содержанию

Вопрос :
Как узнать является диск CD-диском,сетевым диском, виртуальным диском или сьемным диском?
Ответ :
Windows API функция GetDriveType().
Пример :

procedure TForm1.Button1Click(Sender: TObject);
begin
case GetDriveType('C:\') of 0 : ShowMessage('The drive type cannot be determined');
1 : ShowMessage('The root directory does not exist');
DRIVE_REMOVABLE:ShowMessage('The disk can be removed');
DRIVE_FIXED : ShowMessage('The disk cannot be removed');
DRIVE_REMOTE : ShowMessage('The drive is remote (network) drive');
DRIVE_CDROM : ShowMessage('The drive is a CD-ROM drive');
DRIVE_RAMDISK : ShowMessage('The drive is a RAM disk');
end;
end;

Наверх к содержанию

Вопрос :
Как проверить готовность диска без появления окна ошибки Windows?
Ответ :
Вы можете использовать функцию Windows API SetErrorMode() для отключения диалога Window's critical Error.
Пример :

function IsDriveReady(DriveLetter : char) : bool;
var OldErrorMode : Word;
OldDirectory : string;
begin
OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
GetDir(0, OldDirectory);
{$I-}
ChDir(DriveLetter + ':\');
{$I+}
if IoResult <> 0 then Result := False else Result := True;
ChDir(OldDirectory);
SetErrorMode(OldErrorMode);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not IsDriveReady('A') then ShowMessage('Drive Not Ready') else ShowMessage('Drive is Ready');
end;

Наверх к содержанию

Вопрос :
Использование FindFirst для поиска файлов.
Ответ :

begin
Result := SysUtils.FindFirst(Path, Attr, SearchRec);
while Result = 0 do
begin
ProcessSearchRec(SearchRec);
Result := SysUtils.FindNext(SearchRec);
end;
SysUtils.FindClose(SearchRec);
end;

Наверх к содержанию

Вопрос :
Как получить дескриптор окна другого приложения и сделать его активным?
Ответ :
Использование фуекции Windows API FindWindow() - простейший способ нахождение окна, при условии, что известен его заголовок или имя оконного класса. Если Вам известна только часть заголовка окна (например 'Netscape - ' + 'какой-то неизвестный URL'), Вам нужно использовать функцию EnumWindows() для получения всех окон, затем вызывать функцию GetWindowsText() и GetClassName для поиска нужного окна. Следующий пример находит первое окно, содержащее совпадающую часть заголовка окна и полностью совпадающее название оконного класса (если он задан) и делает это окно активным.

type
PFindWindowStruct = ^TFindWindowStruct;
TFindWindowStruct = record
Caption : string;
ClassName : string;
WindowHandle : THandle;
end;
function EnumWindowsProc(hWindow : hWnd; lParam : LongInt) : Bool
{$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF}
var lpBuffer : PChar;
WindowCaptionFound : bool;
ClassNameFound : bool;
begin GetMem(lpBuffer, 255);
Result := True;
WindowCaptionFound := False;
ClassNameFound := False;
try
if GetWindowText(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) > 0 then WindowCaptionFound := true;
if PFindWindowStruct(lParam).ClassName = '' then ClassNameFound := True else
if GetClassName(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) > 0 then ClassNameFound := True;
if (WindowCaptionFound and ClassNameFound) then
begin
PFindWindowStruct(lParam).WindowHandle := hWindow;
Result := False;
end;
finally FreeMem(lpBuffer, sizeof(lpBuffer^));
end;
end;
function FindAWindow(Caption : string; ClassName : string) : THandle;
var WindowInfo : TFindWindowStruct;
begin
with WindowInfo do
begin
Caption := Caption;
ClassName := ClassName;
WindowHandle := 0;
EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo));
FindAWindow := WindowHandle;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var TheWindowHandle : THandle;
begin
TheWindowHandle := FindAWindow('Netscape - ', '');
if TheWindowHandle = 0 then ShowMessage('Window Not Found!') else BringWindowToTop(TheWindowHandle);
end;

Наверх к содержанию

Вопрос :
Как написать программу не имеющую ни одной формы?
Ответ :
Создайте новое приложение, затем удалите из проекта все unitы - (Delphi 3 - View - Project Manager)
(Delphi 4 - Project - Remove from project)
Откройте файл проекта
(Delphi 3 - View - Project Source)
(Delphi 3 - Project - View Source)
и отредактируйте его так как приведино ниже.

Пример :

program Project1;
{$R *.RES}
uses SysUtils;
var f : TextFile;
begin
AssignFile(f, 'TestFile.Txt');
ReWrite(f);
Writeln(f, 'Test');
Close(f);
end.

Наверх к содержанию

Вопрос :
Почему возникает ошибка при передаче параметров типа boolean равного True в некоторые внешней функции
Ответ :
В Delphi 3 значение "True" для типов ByteBool, WordBool LongBool представляется как -1 для совместимости с Microsoft Visual Basic. Многие компиляторы представляют "True" как либо "не нуль" либо 1. При передаче параметров в не Visual Basic-приложения Вам следует придерживаться следующей техники во избежание несовместимости:

LongBool(Abs(True));

При приеме значений типа boolean из внешних программ Вам следует всегда проверять его на значение "False". Эта техника всегда работает, поскольку "False" всегда представляется нулем.

if BoolValPassed <> False then DoSomething.

Наверх к содержанию

Вопрос :
Как получить длинное имя файла или каталога, зная короткое имя?
Ответ :
Используйте Win32_Find_Data поле TSearchRec.
Пример :

procedure TForm1.Button1Click(Sender: TObject);
var SearchRec : TSearchRec;
Success : integer;
begin
Success := SysUtils.FindFirst('C:\DownLoad\dial-u~1.htm', faAnyFile, SearchRec);
if Success = 0 then begin ShowMessage(SearchRec.FindData.CFileName);
end;
SysUtils.FindClose(SearchRec);
end;

Наверх к содержанию

Вопрос :
Как временно отключить range checking для участка программы, а затем вновь вклчить его?
Ответ :
Можно сделать это, используя "IFOPT" и "DEFINE".

type
PSomeArray = ^TSomeArray;
TSomeArray = array[0..0] of integer;
procedure TForm1.Button1Click(Sender: TObject);
var p : PSomeArray;
i : integer;
begin
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}
GetMem(p, sizeof(integer) * 200);
try
for i := 1 to 200 do p[i] := i;
finally
FreeMem(p, sizeof(integer) * 200);
end;
{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;

Наверх к содержанию

Вопрос :
Как получить имя файла и путь локальной таблицы?
Ответ :
Следующий пример взят из файла BDE32.HLP Borland/CommonFiles/BDE directory:

implementation
{$R *.DFM}
uses DbiTypes, DbiProcs;
function fDbiFormFullName(Tbl: TTable): String;
var
Props: CurProps;
Buffer1 : array[0..DBIMAXPATHLEN] of char;
Buffer2 : array[0..DBIMAXPATHLEN] of char;
begin
Check(DbiGetCursorProps(Tbl.Handle,Props));
StrPCopy(Buffer1, Tbl.TableName);
Check(DbiFormFullName(Tbl.DBHandle, @Buffer1, Props.szTableType, @Buffer2));
Result := StrPas(Buffer2);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Lines.Add(fDbiFormFullName(Table1));
end;
Примечание: Таблица должна быть открытой. Работает с локальными таблицами.

Наверх к содержанию

Вопрос :
Как получить дескриптор панели задач (TaskBar)?
Ответ :
hTaskbar := FindWindow('Shell_TrayWnd', Nil );

Наверх к содержанию

Вопрос :
Как из программы запустить Screen Saver?
Ответ :
Представленная ниже функция демонстрирует как это сделать

function TurnScreenSaverOn : bool;
var b : bool;
begin
result := false;
if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @b, 0) <> true then exit;
if not b then exit;
PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
result := true;
end;

Наверх к содержанию

Вопрос :
Как выяснить установлены ли в системе шрифты TrueType?
Ответ :

function IsTrueTypeAvailable : bool;
var
{$IFDEF WIN32}
rs : TRasterizerStatus;
{$ELSE}
rs : TRasterizer_Status;
{$ENDIF}
begin
result := false;
if not GetRasterizerCaps(rs, sizeof(rs)) then exit;
if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then exit;
if rs.WFlags and TT_ENABLED <> TT_ENABLED then exit;
result := true;
end;

Наверх к содержанию

Вопрос :
Как переслать файл в Мусорную Корзину?
Ответ :
Используйте функцию SHFileOperation().

uses ShellAPI;
procedure SendToRecycleBin(FileName: string);
var SHF: TSHFileOpStruct;
begin
with SHF do
begin
Wnd := Application.Handle;
wFunc := FO_DELETE;
pFrom := PChar(FileName);
fFlags := FOF_SILENT or FOF_ALLOWUNDO;
end;
SHFileOperation(SHF);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SendToRecycleBin('c:\DownLoad\Test.gif');
end;

Наверх к содержанию

Вопрос :
Как изменить обои Windows програмно?
Ответ :
Изменить обои можно функцией SystemParametersInfo()Б переслав ей в качестве параметров константу SPI_SETDESKWALLPAPER и имя нового файла обоев.
Пример :

SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar('C:\SOMEPATH\SOME.BMP'), SPIF_SENDWININICHANGE);

Наверх к содержанию

Вопрос :
Как выяснить запущен ли Delphi / C++ Builder?
Ответ :
Используйте функцию FindWindow. (Класс главного окна Delphi / C++ Builder - TAppBuilder)

if FindWindow('TAppBuilder', Nil) <> 0 Then ShowMessage('Delphi and or C++ Builder is running');

Наверх к содержанию

Вопрос :
Как програмно выяснить версию Windows?
Ответ :

{$IFDEF WIN32}
function GetVersionEx(lpOs : pointer) : BOOL; stdcall; external 'kernel32' name 'GetVersionExA';
{$ENDIF}
procedure GetWindowsVersion(var Major : integer; var Minor : integer);
var
{$IFDEF WIN32}
lpOS, lpOS2 : POsVersionInfo;
{$ELSE}
l : longint;
{$ENDIF}
begin
{$IFDEF WIN32}
GetMem(lpOS, SizeOf(TOsVersionInfo));
lpOs^.dwOSVersionInfoSize := SizeOf(TOsVersionInfo);
while getVersionEx(lpOS) = false do
begin
GetMem(lpos2, lpos^.dwOSVersionInfoSize + 1);
lpOs2^.dwOSVersionInfoSize := lpOs^.dwOSVersionInfoSize + 1;
FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
lpOS := lpOs2;
end;
Major := lpOs^.dwMajorVersion;
Minor := lpOs^.dwMinorVersion; FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
{$ELSE}
l := GetVersion;
Major := LoByte(LoWord(l));
Minor := HiByte(LoWord(l));
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
var Major : integer;
Minor : integer;
begin
GetWindowsVersion(Major, Minor);
Memo1.Lines.Add(IntToStr(Major));
Memo1.Lines.Add(IntToStr(Minor));
end;

Наверх к содержанию

Вопрос :
Как узнать переменные окружения (environment variable) DOS, например path?
Ответ :

Windows API - функция GetDOSEnvironment() для Win16 и GetEnvironmentStrings() для Win32.

Пример :

procedure TForm1.Button1Click(Sender: TObject);
var p : pChar;
begin
Memo1.Lines.Clear;
Memo1.WordWrap := false;
{$IFDEF WIN32}
p := GetEnvironmentStrings;
{$ELSE}
p := GetDOSEnvironment;
{$ENDIF}
while p^ <> #0 do
begin
Memo1.Lines.Add(StrPas(p));
inc(p, lStrLen(p) + 1);
end;
{$IFDEF WIN32}
FreeEnvironmentStrings(p);
{$ENDIF}
end;

Наверх к содержанию

Вопрос :
Как рисовать непосредственно на Рабочем столе?
Ответ :

Пример :

procedure TForm1.Button1Click(Sender: TObject);
var dc : hdc;
begin
dc := GetDc(0);
MoveToEx(Dc, 0, 0, nil);
LineTo(Dc, 300, 300);
ReleaseDc(0, Dc);
end;

Наверх к содержанию

Вопрос :
Как определить каталог Windows?
Ответ :
Вызовите функцию GetWindowsDirectory(). Если Вас интересует каталог System, вызовите функцию GetSystemDirectory().
Пример :

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}
procedure TForm1.Button1Click(Sender: TObject);
var a : Array[0..MAX_PATH] of char;
begin
GetWindowsDirectory(a, sizeof(a));
ShowMessage(StrPas(a));
GetSystemDirectory(a, sizeof(a));
ShowMessage(StrPas(a));
end;

Наверх к содержанию

Вопрос :
Как определить размер рабочего стола без Тaskbar'а?
Ответ :
Воспользуйтесь функцией SystemParametersInfo(), переслав ей в качестве параметров - SPI_GETWORKAREA и адрес структуры типа TRect, куда будут передан полученный результат.
Пример :

procedure TForm1.Button1Click(Sender: TObject);
var r : TRect;
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
Memo1.Lines.Add(IntToStr(r.Top));
Memo1.Lines.Add(IntToStr(r.Left));
Memo1.Lines.Add(IntToStr(r.Bottom));
Memo1.Lines.Add(IntToStr(r.Right));
end;

Наверх к содержанию

Вопрос :
Как закрыть CD програмно?
Ответ :
Вызовите функцию mciSendCommand (из библиотекиMMSystem) передав ей параметр MCI_SET_DOOR_CLOSED.
Пример :

uses MMSystem;
procedure CloseCD(Drive : char);
var mp : TMediaPlayer;
begin
result := false;
Application.ProcessMessages;
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := Drive + ':';
mp.Open;
Application.ProcessMessages;
mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
Application.ProcessMessages;
mp.Close;
Application.ProcessMessages; mp.free; result := true;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CloseCD('D');
end;

Наверх к содержанию

Вопрос :
Как определить свободное дисковое пространство на дисках размером больше 2 ГБ?
Ответ :
Вызовите функцию GetDiskFreeSpaceEx(). Возвращаемый функцией результат типа integers конвертируйте в doubles.
Пример :

function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar; var lpFreeBytesAvailableToCaller : Integer; var lpTotalNumberOfBytes: Integer; var lpTotalNumberOfFreeBytes: Integer) : bool; stdcall; external kernel32 name 'GetDiskFreeSpaceExA';
procedure GetDiskSizeAvail(TheDrive : PChar; var TotalBytes : double; var TotalFree : double);
var
AvailToCall : integer;
TheSize : integer;
FreeAvail : integer;
begin
GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail);
{$IFOPT Q+}
{$DEFINE TURNOVERFLOWON}
{$Q-}
{$ENDIF}
if TheSize >= 0 then TotalBytes := TheSize else
if TheSize = -1 then
begin
TotalBytes := $7FFFFFFF;
TotalBytes := TotalBytes * 2;
TotalBytes := TotalBytes + 1;
end else
begin
TotalBytes := $7FFFFFFF;
TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize);
end;
if AvailToCall >= 0 then TotalFree := AvailToCall else
if AvailToCall = -1 then
begin
TotalFree := $7FFFFFFF;
TotalFree := TotalFree * 2;
TotalFree := TotalFree + 1;
end else
begin
TotalFree := $7FFFFFFF;
TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
TotalBytes : double;
TotalFree : double;
begin
GetDiskSizeAvail('C:\', TotalBytes, TotalFree);
ShowMessage(FloatToStr(TotalBytes));
ShowMessage(FloatToStr(TotalFree));
end;

Наверх к содержанию

Вопрос :
Как спрятать Панель Задач Windows (Task Bar)?
Ответ :
Вначале необходимо вызвать функцию FindWindow(), чтобы определить handle TaskBar. Затем вызвите функцию ShowWindow(), передав ей в качестве параметра костанту SW_HIDE.
Пример :

procedure TForm1.Button1Click(Sender: TObject);
var hTaskBar : THandle;
begin
hTaskbar := FindWindow('Shell_TrayWnd', Nil);
ShowWindow(hTaskBar, SW_HIDE);
end;
procedure TForm1.Button2Click(Sender: TObject);
var hTaskBar : THandle;
begin
hTaskbar := FindWindow('Shell_TrayWnd', Nil);
ShowWindow(hTaskBar, SW_SHOWNORMAL);
end;

Наверх к содержанию

Вопрос :
Как определить подключен ли компюетер к сети.
Ответ :
Воспользуйтесь функцией GetSystemMetrics(), переслав ей флаг SM_NETWORK.
Пример :

procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then ShowMessage('Machine is attached to network') else ShowMessage('Machine is not attached to network');
end;

Наверх к содержанию

Вопрос :
Как добавить документ в меню ПУСК - ДОКУМЕНТЫ?
Ответ :
Используйте функцию SHAddToRecentDocs.
Пример :

uses ShlOBJ;
procedure TForm1.Button1Click(Sender: TObject);
var s : string;
begin
s := 'C:\DownLoad\ntkfaq.html';
SHAddToRecentDocs(SHARD_PATH, pChar(s));
end;

Наверх к содержанию

Вопрос :
Как программно изменить текущий порт принтера?
Ответ :
Используйте метод SetPrinter класса TPrinter.
Пример :

uses Printers;
{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}
procedure TForm1.Button1Click(Sender: TObject);
var pDevice : pChar;
pDriver : pChar;
pPort : pChar;
hDMode : THandle;
PDMode : PDEVMODE;
begin
if PrintDialog1.Execute then
begin
GetMem(pDevice, cchDeviceName);
GetMem(pDriver, MAX_PATH);
GetMem(pPort, MAX_PATH);
Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);
Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode);
FreeMem(pDevice, cchDeviceName);
FreeMem(pDriver, MAX_PATH);
FreeMem(pPort, MAX_PATH);
Printer.BeginDoc;
Printer.Canvas.TextOut(100, 100, 'Delphi Is RAD!');
Printer.EndDoc;
end;
end;

Наверх к содержанию

Вопрос :
Как корректно определить изменения в оборудовании PlugNPlay?
Ответ :

Пример :

type
TForm1 = class(TForm)
Button1: TButton;
private
{ Private declarations }
procedure WMDeviceChange(var Message: TMessage);
message WM_DEVICECHANGE;
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
const DBT_DEVICEARRIVAL = $8000;
const DBT_DEVICEQUERYREMOVE = $8001;
const DBT_DEVICEQUERYREMOVEFAILED = $8002;
const DBT_DEVICEREMOVEPENDING = $8003;
const DBT_DEVICEREMOVECOMPLETE = $8004;
const DBT_DEVICETYPESPECIFIC = $8005;
const DBT_CONFIGCHANGED = $0018;
procedure TForm1.WMDeviceChange(var Message: TMessage);
var s : string;
begin
{Do Something here}
case Message.wParam of DBT_DEVICEARRIVAL : s := 'A device has been inserted and is now available';
DBT_DEVICEQUERYREMOVE:
begin
s := 'Permission to remove a device is requested'; ShowMessage(s);
{True grants premission}
Message.Result := integer(true);
exit;
end;
DBT_DEVICEQUERYREMOVEFAILED : s := 'Request to remove a device has been canceled';
DBT_DEVICEREMOVEPENDING : s := 'Device is about to be removed';
DBT_DEVICEREMOVECOMPLETE : s := 'Device has been removed';
DBT_DEVICETYPESPECIFIC : s := 'Device-specific event';
DBT_CONFIGCHANGED : s:= 'Current configuration has changed' else s := 'Unknown Device Message';
end;
ShowMessage(s);
inherited;
end;

Наверх к содержанию

Вопрос :
Как после записи в ini-файл сбросить cache на диск, чтоб задействовать изменения?
Ответ :
Вызовите функцию WriteProfileString() или WritePrivateProfileString(), передав ей в качестве параметров секции, ключа и строки - nil.
Пример :

WriteProfileString(nil, nil, nil); WritePrivateProfileString(nil, nil, nil, FileName);

Наверх к содержанию

Вопрос :
Как с помощью Проводника открыть конкретный каталог?
Ответ :

Пример :

uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(0, 'explore', 'C:\WINDOWS', nil, nil, SW_SHOWNORMAL);
end;

Наверх к содержанию

Вопрос :
Как запустить аплет Панели управления?
Ответ :
Запустить аплет Панели управления можно вызвав функцию WinExec, для выполнения файла control.exe, которому передано имя аплета. Обычно аплеты панели управления расположены в каталоге System Windows и имеют расширение .cpl.
Пример :

procedure TForm1.Button1Click(Sender: TObject);
begin
WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL', sw_ShowNormal);
WinExec('C:\WINDOWS\CONTROL.EXE MOUSE', sw_ShowNormal);
WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS', sw_ShowNormal);
end;

Наверх к содержанию

Вопрос :
Как печатать в цвете?
Ответ :
Обычно нет необходимости переводить принтер в режим цветной печати, если он установлен в этот режим. Windows автоматически переведет цветную печать в черно-белую, если принтер не поддерживает цветной печати. Если Вам необходимо програмно изменить режим цвета, Вы можете обратится к структуре DevMode драйвера принтера.
Пример :

uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
var Device : array[0..255] of char;
Driver : array[0..255] of char;
Port : array[0..255] of char;
hDMode : THandle;
PDMode : PDEVMODE;
begin
with Printer do
begin
PrinterIndex := PrinterIndex;
GetPrinter(Device, Driver, Port, hDMode);
if hDMode <> 0 then
begin
pDMode := GlobalLock(hDMode);
if pDMode <> nil then
begin
pDMode.dmFields := pDMode.dmFields or dm_Color;
pDMode.dmColor := DMCOLOR_COLOR;
GlobalUnlock(hDMode);
end;
end;
PrinterIndex := PrinterIndex;
BeginDoc;
Canvas.Font.Color := clRed;
Canvas.TextOut(100,100, 'Red As A Rose!');
EndDoc;
end;
end;

Наверх к содержанию

Вопрос :
Как открыть URL браузером, установленным по умолчанию?
Ответ :
Используйте функцию ShellExecute.
Пример :

uses ShellAPI;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(Form1.Handle, nil, 'http://www.borland.com', nil, nil, SW_SHOWNORMAL);
end;

Наверх к содержанию

Вопрос :
Как стереть ехе-файл во время его исполнения?
Ответ :
Это не возможно. Вы можете стереть его во время следующего запуска Windows, добавив ключ RunOnce:

HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce

Пример :

uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var reg: TRegistry;
begin
reg := TRegistry.Create;
with reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
LazyWrite := false;
OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', false);
WriteString('Delete Me!','command.com /c del FILENAME.EXT');
CloseKey;
free;
end;
end;

Наверх к содержанию

Вопрос :
Как програмноинсталировать шрифты TrueType?
Ответ :
Скопируйте файл шрифта в директорию Windows\Fonts, и добавьте строку с именем шрифта и его расположением в разделе "'Software\Microsoft\Windows\CurrentVersion\Fonts". Вызовите функцию AddFontRecource(), а затем передайте системе сообщение WM_FONTCHANGE. И наконец, для удоления установленного шрифта, вызовите функцию RemoveFontRecource(), а затем передайте системе сообщение WM_FONTCHANGE.
Пример :

uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
b : bool;
begin
CopyFile('C:\DOWNLOAD\FP000100.TTF', 'C:\WINDOWS\FONTS\FP000100.TTF', b);
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', false);
reg.WriteString('TESTMICR (TrueType)','FP000100.TTF');
reg.CloseKey;
reg.free;
{Add the font resource}
AddFontResource('c:\windows\fonts\FP000100.TTF');
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
{Remove the resource lock}
RemoveFontResource('c:\windows\fonts\FP000100.TTF');
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

Наверх к содержанию

Вопрос :
Как получить список часовых поясов?
Ответ :

Пример :

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( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false);
if reg.HasSubKeys then
begin
ts := TStringList.Create;
reg.GetKeyNames(ts);
reg.CloseKey;
for i := 0 to ts.Count -1 do
begin
reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false);
Memo1.Lines.Add(ts.Strings[i]);
Memo1.Lines.Add(reg.ReadString('Display'));
Memo1.Lines.Add(reg.ReadString('Std'));
Memo1.Lines.Add(reg.ReadString('Dlt'));
Memo1.Lines.Add('----------------------');
reg.CloseKey;
end;
ts.Free;
end else reg.CloseKey;
reg.free;
end;

Наверх к содержанию

Вопрос :
Какие значения возвращает функция GetTimeZoneInformation()?
Ответ :

const TIME_ZONE_ID_UNKNOWN = 0;
const TIME_ZONE_ID_STANDARD = 1;
const TIME_ZONE_ID_DAYLIGHT = 2;

Наверх к содержанию

Вопрос :
Как сделать прозрачным фон текста?
Ответ :
Используйте функцию SetBkMode().
Пример :

procedure TForm1.Button1Click(Sender: TObject);
var OldBkMode : integer;
begin
with Form1.Canvas do
begin
Brush.Color := clRed;
FillRect(Rect(0, 0, 100, 100));
Brush.Color := clBlue;
TextOut(10, 20, 'Not Transparent!');
OldBkMode := SetBkMode(Handle, TRANSPARENT);
TextOut(10, 50, 'Transparent!');
SetBkMode(Handle, OldBkMode);
end;
end;

Наверх к содержанию

Вопрос :
Как получить информацию о версии файла?
Ответ :
Для этого необходимо вызвать несколько функций API. В приведеннном ниже примере проверяется версия shell32.dll. Функция возвращает значение True - если версия DLL больше или равна 4.71

function TForm1.CheckShell32Version: Boolean;
procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Integer);
{ Helper function to get the actual file version information }
var
Info: Pointer;
InfoSize: DWORD;
FileInfo: PVSFixedFileInfo;
FileInfoSize: DWORD;
Tmp: DWORD;
begin
// Get the size of the FileVersionInformatioin InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp);
// If InfoSize = 0, then the file may not exist, or
// it may not have file version information in it.
if InfoSize = 0 then raise Exception.Create('Can''t get file version information for ' + FileName);
// Allocate memory for the file version information GetMem(Info, InfoSize); try
// Get the information GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info);
// Query the information for the version VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize);
// Now fill in the version information Major1 := FileInfo.dwFileVersionMS shr 16; Major2 := FileInfo.dwFileVersionMS and $FFFF;
Minor1 := FileInfo.dwFileVersionLS shr 16;
Minor2 := FileInfo.dwFileVersionLS and $FFFF;
finally
FreeMem(Info, FileInfoSize);
end;
end;
var
tmpBuffer: PChar;
Shell32Path: string;
VersionMajor: Integer;
VersionMinor: Integer;
Blank: Integer;
begin
tmpBuffer := AllocMem(MAX_PATH);
// Get the shell32.dll path
try
GetSystemDirectory(tmpBuffer, MAX_PATH);
Shell32Path := tmpBuffer + '\shell32.dll';
finally
FreeMem(tmpBuffer);
end;
// Check to see
if it exists if FileExists(Shell32Path) then
begin
// Get the file version GetFileVersion(Shell32Path, VersionMajor, VersionMinor, Blank, Blank);
// Do something, such as require a certain version
// (such as greater than 4.71)
if (VersionMajor >= 4) and (VersionMinor >= 71) then
Result := True else Result := False;
end else Result := False;
end;

Наверх к содержанию

Вопрос :
Как создать иконку из bitmap'а?
Ответ :
Нужно создать два bitmap'а: bitmap-маску ("AND" bitmap) и bitmap-картинку (XOR bitmap). Потом передать дескрипторы "AND" и "XOR" bitmap-ов API функции CreateIconIndirect()
Пример :

procedure TForm1.Button1Click(Sender: TObject);
var
IconSizeX : integer;
IconSizeY : integer;
AndMask : TBitmap;
XOrMask : TBitmap;
IconInfo : TIconInfo;
Icon : TIcon;
begin
{Get the icon size}
IconSizeX := GetSystemMetrics(SM_CXICON);
IconSizeY := GetSystemMetrics(SM_CYICON);
{Create the "And" mask}
AndMask := TBitmap.Create;
AndMask.Monochrome := true;
AndMask.Width := IconSizeX;
AndMask.Height := IconSizeY;
{Draw on the "And" mask}
AndMask.Canvas.Brush.Color := clWhite;
AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
AndMask.Canvas.Brush.Color := clBlack; AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);
{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);
{Create the "XOr" mask}
XOrMask := TBitmap.Create;
XOrMask.Width := IconSizeX;
XOrMask.Height := IconSizeY;
{Draw on the "XOr" mask}
XOrMask.Canvas.Brush.Color := ClBlack;
XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
XOrMask.Canvas.Pen.Color := clRed;
XOrMask.Canvas.Brush.Color := clRed;
XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);
{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);
{Create a icon}
Icon := TIcon.Create;
IconInfo.fIcon := true;
IconInfo.xHotspot := 0;
IconInfo.yHotspot := 0;
IconInfo.hbmMask := AndMask.Handle;
IconInfo.hbmColor := XOrMask.Handle;
Icon.Handle := CreateIconIndirect(IconInfo);
{Destroy the temporary bitmaps}
AndMask.Free;
XOrMask.Free;
{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);
{Assign the application icon}
Application.Icon := Icon;
{Force a repaint}
InvalidateRect(Application.Handle, nil, true);
{Free the icon}
Icon.Free;
end;

Наверх к содержанию

Вопрос :
Как преобразовать RGB-цвет в оттенки серого?
Ответ :
В приведенном примере для преобразования RGB-цвета используются коэффициенты, принятые в телевидении:

function RgbToGray(RGBColor : TColor) : TColor;
var Gray : byte;
begin
Gray := Round((0.30 * GetRValue(RGBColor)) + (0.59 * GetGValue(RGBColor)) + (0.11 * GetBValue(RGBColor )));
Result := RGB(Gray, Gray, Gray);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Shape1.Brush.Color := RGB(255, 64, 64);
Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);
end;

Наверх к содержанию

Вопрос :
Как держать приложение в минимизированном виде?
Ответ :
Установите свойство WindowState в Minimized. Создайте обработчик сообщения WM_QueryOpen.
Пример :

{Place this code in the private section of the Form declaration}
procedure WMQueryOpen(VAR Msg : TWMQueryOpen);
message WM_QUERYOPEN;
{Place this code in the Form implementation section}
procedure TForm1.WMQueryOpen(VAR Msg : TWMQueryOpen);
begin
Msg.Result := 0;
end;

Наверх к содержанию

Вопрос :
при вызове функции RegisterClass я получаю ошибку: "Incompatible types: 'TPersistantClass' and 'TWndClassA'"
Ответ :
Функция RegisterClass() обьявлена в модулях Classes и Windows unit. Чтобы вызвать функцию из модуля Windows просто добавте префикс "Windows."
Пример :

procedure TForm1.Button1Click(Sender: TObject);
wc : TWndClass;
begin
Windows.RegisterClass(wc)
end;

Наверх к содержанию

Вопрос :
Как принять файлы, брошенные на мою форму по drag & drop
Ответ :
Нужно сообщить Windows, что ваша форма принимает файлы по drag & drop с помощью функции Shell API DragAcceptFiles.(в обработчике события form create) Затем нужно реагироавть на сообытия drag & drop чтобы принять файлы. (см. пример)

unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
procedure WMDROPFILES(var Message: TWMDROPFILES);
message WM_DROPFILES;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses ShellApi;
procedure TForm1.FormCreate(Sender: TObject);
begin
{Let Windows know we accept dropped files}
DragAcceptFiles(Form1.Handle, True);
end;
procedure TForm1.WMDROPFILES(var Message: TWMDROPFILES);
var
NumFiles : longint;
i : longint;
buffer : array[0..255] of char;
begin
{How many files are being dropped}
NumFiles := DragQueryFile(Message.Drop, -1, nil, 0);
{Accept the dropped files}
for i := 0 to (NumFiles - 1) do
begin
DragQueryFile(Message.Drop, i, @buffer, sizeof(buffer));
Form1.Memo1.Lines.Add(buffer);
end;
end;
end.

Наверх к содержанию

Вопрос :

Как создать задержку не подвешивая систему без компонента TTimer ?
Ответ :
В примере используется вызов Application.ProcessMessages для того, чтобы Windows обрабатывал сообщения во время цикла задержки.

procedure Delay(ms : longint);
var TheTime : LongInt;
begin
TheTime := GetTickCount + ms;
while GetTickCount < TheTime do
Application.ProcessMessages;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Start Test');
Delay(2000);
ShowMessage('End Test');
end;

Наверх к содержанию

Вопрос :

Как програмно перезагрузить Windows? Ответ :

Используйте функцию ExitWindows(). В качестве первого параметра ей передается она из трех констант: EW_RESTARTWINDOWS EW_REBOOTSYSTEM EW_EXITANDEXECAPP Второй параметр используется для перезагрузки компьютера в режиме эмуляции MS DOS.


Пример :

ExitWindows(EW_RESTARTWINDOWS, 0 );

Наверх к содержанию

 

Опрос

Конкурсы
Реклама

 

Web дизайн: Бурлаков Михаил    

Web программирование: Бурлаков Михаил

Используются технологии uCoz
?????? ??????? ?? ??????? ?????? ????????
Яркая мелодия лета магазин парфюмерия косметика онлайн консультант