Иногда всплывающее меню моего приложения 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;
Наверх к содержанию
Вопрос:
При изменении размеров формы мне необходимо чтобы перерисовывалась вся ее поверхность.
Но свойство 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;
Наверх к содержанию
Вопрос:
Как спрятать и отключить кнопку "Пуск"? Ответ:
Приведенный пример прячет и показывает кнопку "Пуск", а также разрешает и запрещает
ее. Пример:
Наверх к содержанию
Вопрос:
Как временно отключить перерисовку окна? Ответ:
Вызовите функцию WinAPI LockWindowUpdate передав ей дескриптор окна, которое необходимо
не обновлять. Передайте ноль в качестве параметра для восстановления нормального
обновления.
Наверх к содержанию
Вопрос:
Моя программа использует дравер принтера. Возможно ли потихоньку установить драйвер
принтера без вмешательства пользователя? Ответ:
Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать
файлы с драйвером принтера в каталог 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 для голосового звонка? Ответ:
См пример. Пример:
Наверх к содержанию
Вопрос:
Как определение нажатия определенной клавиши во время загрузки приложения? Ответ:
Используйту 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 обновится? Ответ:
См. пример. Пример:
Наверх к содержанию
Вопрос:
Перерисовка 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. Пример:
Наверх к содержанию
Вопрос:
Я хочу определить момент окончания изменения размера или перемещения окна. Перехватываю
сообщения 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.
Наверх к содержанию
Вопрос:
Можно ли скопировать группу файлов, используя стандартный диалог с анимацией Копирование
Файлов, который использует "Проводник" (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;
Наверх к содержанию
Вопрос:
Как узнать является диск 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;
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 и имя нового файла обоев. Пример:
Наверх к содержанию
Вопрос:
Как выяснить запущен ли Delphi / C++ Builder? Ответ:
Используйте функцию FindWindow. (Класс главного окна Delphi / C++ Builder — TAppBuilder)
if FindWindow('TAppBuilder', Nil) <> 0 Then
ShowMessage('Delphi and or C++ Builder is running');
{$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. Пример:
Наверх к содержанию
Вопрос:
Как определить свободное дисковое пространство на дисках размером больше 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. Пример:
Наверх к содержанию
Вопрос:
Как корректно определить изменения в оборудовании 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. Пример:
Наверх к содержанию
Вопрос:
Как запустить аплет Панели управления? Ответ:
Запустить аплет Панели управления можно вызвав функцию WinExec, для выполнения
файла control.exe, которому передано имя аплета. Обычно аплеты панели управления
расположены в каталоге System Windows и имеют расширение .cpl. Пример:
Наверх к содержанию
Вопрос:
Как печатать в цвете? Ответ:
Обычно нет необходимости переводить принтер в режим цветной печати, если он установлен
в этот режим. 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. Пример:
Наверх к содержанию
Вопрос:
Как стереть ехе-файл во время его исполнения? Ответ:
Это не возможно. Вы можете стереть его во время следующего запуска Windows, добавив
ключ 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;
Наверх к содержанию
Вопрос:
Как сделать прозрачным фон текста? Ответ:
Используйте функцию 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;