Вопрос:
Как программно выключить монитор?
Ответ:
Программно можно отключить монитор совместимый
со стандартом 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 <> 0then
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 );
Наверх к содержанию
(c) 1999 Inprise Corp. Last Modified Friday, 06-Aug-99 11:12:04 PST. Translated & Adapted by mailto:aziz@telebot.net 17-Aug-1999