|
:: MVP ::
|
|
|
:: RSS ::
|
|
|
Как закрыть модальное окно при клике в неклиентской области?
// Главная форма
unit Unit1;
{...}
implementation
uses
Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin
with TForm2.Create(Self) do
begin
ShowModal;
Free;
end;
end;
// Модальная форма
unit Unit2;
type
TForm2 = class(TForm)
private
procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCACTIVATE;
{...}
end;
implementation
procedure TForm2.WMNCActivate(var Msg: TWMNCActivate);
begin
inherited;
if (fsModal in FormState) and not Msg.Active then
begin
//Msg.Result := 1;
Close;
end;
end;
|
Как изменить приоритет своего приложения?
procedure TForm1.Button1Click(Sender: TObject);
var
ProcessID: DWORD;
ProcessHandle: THandle;
ThreadHandle: THandle;
begin
ProcessID := GetCurrentProcessID;
ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, False, ProcessID);
SetPriorityClass(ProcessHandle, HIGH_PRIORITY_CLASS);
ThreadHandle := GetCurrentThread;
SetThreadPriority(ThreadHandle, THREAD_PRIORITY_HIGHEST);
end;
|
Как установить точные размеры клиентской области окна?
// Способ первый
// Для своего окна
procedure TForm1.Button1Click(Sender: TObject);
begin
ClientWidth := 200;
ClientHeight := 200;
end;
// Способ первый
// Для любого окна
procedure SetClientRect(AHandle: THandle; AClientWidth, AClientHeight: Integer);
var
r: TRect;
b: Boolean;
begin
GetWindowRect(AHandle, r);
r.Right := r.Left + AClientWidth;
r.Bottom := r.Top + AClientHeight;
// Определяем есть ли меню
b := GetMenu(AHandle) > 0;
if b then
// Если есть, то видно ли оно
if GetMenuItemCount(GetMenu(AHandle)) = 0 then
// Если видно, корректируем размер
r.Bottom := r.Bottom - GetSystemMetrics(SM_CYMENU);
// Альтернативный способ определения видимости меню
// b := (GetMenu(AHandle) > 0) and (GetMenuItemCount(GetMenu(AHandle)) > 0);
// Корректируем размер с учетом видимости горизонтальной полосы прокрутки
if GetWindowLong(AHandle, GWL_STYLE) and WS_HSCROLL = WS_HSCROLL then
r.Right := r.Right + GetSystemMetrics(SM_CXHSCROLL);
// Корректируем размер с учетом видимости вертикальной полосы прокрутки
if GetWindowLong(AHandle, GWL_STYLE) and WS_VSCROLL = WS_VSCROLL then
r.Bottom := r.Bottom + GetSystemMetrics(SM_CYVSCROLL);
// Вычисление нового размера окна
AdjustWindowRectEx(r, GetWindowLong(AHandle, GWL_STYLE),
b, GetWindowLong(AHandle, GWL_EXSTYLE));
SetWindowPos(AHandle, HWND_TOP, r.Left, r.Top, r.Right - r.Left,
r.Bottom - r.Top, SWP_NOZORDER or SWP_NOMOVE);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetClientRect(Handle, 200, 200);
end;
|
Как определить что приложение запущено под Wine?
// Способ первый
function GetWineAvail(out WineVersion: string): Boolean;
type
TWineGetVersion = function: PAnsiChar; cdecl;
var
ntdll: HMODULE;
pwine_get_version: TWineGetVersion;
begin
ntdll := GetModuleHandle('ntdll.dll');
if ntdll = 0 then
Exit(False);
// Специфичные для Wine функции, которые можно искать в ntdll
// __wine_ctrl_routine
// __wine_dbg_get_channel_flags
// __wine_dbg_header
// __wine_dbg_output
// __wine_dbg_strdup
// __wine_dbg_write
// __wine_set_unix_funcs
// __wine_syscall_dispatcher
// __wine_unix_call
// __wine_unix_spawnvp
// wine_get_build_id
// wine_get_host_version
// wine_get_version
// wine_nt_to_unix_file_name
// wine_server_call
// wine_server_fd_to_handle
// wine_server_handle_to_fd
// wine_unix_to_nt_file_name
pwine_get_version := GetProcAddress(ntdll, 'wine_get_version');
if Assigned(pwine_get_version) then
WineVersion := UTF8ToString(pwine_get_version)
else
Exit(False);
Result := True;
end;
// Или немного проще
// function GetWineAvail: Boolean;
// var
// h: HMODULE;
// begin
// Result := False;
// h := GetModuleHandle('ntdll.dll');
// if h > 0 then
// Result := Assigned(GetProcAddress(h, 'wine_get_version'));
// end;
procedure TForm1.Button1Click(Sender: TObject);
var
WineVersion: string;
begin
if GetWineAvail(WineVersion) then
ShowMessage('Приложение запущено под Wine... ' + WineVersion);
end;
// Способ второй
uses
{...,} Registry;
function GetWineAvail: Boolean;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Result := Reg.KeyExists('Software\Wine');
if not Result then
begin
Reg.RootKey := HKEY_LOCAL_MACHINE;
Result := Reg.KeyExists('Software\Wine');
end;
finally
Reg.CloseKey;
Reg.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if GetWineAvail then
ShowMessage('Приложение запущено под Wine... ');
end;
|
Как сделать форму "прозрачной" для кликов мыши?
type
TForm1 = class(TForm)
private
procedure CreateParams(var Params: TCreateParams); override;
{...}
end;
implementation
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
ExStyle := ExStyle or WS_EX_TRANSPARENT;
end;
|
Как добавить курсор в своё приложение?
// Из файла, работает со статическими (cur) и анимированными (ani) курсорами
const
MyCursor = 100;
procedure TForm1.Button1Click(Sender: TObject);
begin
Screen.Cursors[MyCursor] := LoadCursorFromFile('File.cur');
// Screen.Cursors[MyCursor] := LoadCursorFromFile('File.ani');
Screen.Cursor := MyCursor;
end;
// Статический курсор (cur) из ресурса
const
MyCursor = 100;
procedure TForm1.Button1Click(Sender: TObject);
begin
// RESNAME - имя ресурса с курсором
Screen.Cursors[MyCursor] := LoadCursor(hInstance, 'RESNAME');
Screen.Cursor := MyCursor;
end;
// Динамический курсор (ani) из ресурса
const
CursorPrecision = 100;
function GetResourceAsAniCursor(const ResName: string; Width, Height: Integer): HCursor;
var
resInfo: HRSRC;
resSize: Cardinal;
resHandle: HGLOBAL;
resData, Data: PChar;
begin
Result := 0;
resInfo := FindResource(MainInstance, PWideChar(ResName), PWideChar('ANICURSOR'));
resHandle := LoadResource(MainInstance, resInfo);
if resHandle <> 0 then
begin
resSize := SizeofResource(MainInstance, resInfo);
resData := LockResource(resHandle);
Data := AllocMem(resSize);
try
Move(resData^, Data^, resSize);
Result := CreateIconFromResourceEx(PByte(Data), resSize, False, $00030000, Width, Height, 0);
finally
FreeMem(Data);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Screen.Cursors[CursorPrecision] := GetResourceAsAniCursor('Aim', 32, 32);
Screen.Cursor := CursorPrecision;
end;
|
Как получить заголовок окна (или любого оконного компонента)?
// Способ первый
function GetwndText(AWnd: THandle): string;
var
WndCaptionLen: Word;
begin
WndCaptionLen := GetWindowTextLength(AWnd) + 1;
if WndCaptionLen > 1 then
begin
SetLength(Result, WndCaptionLen);
GetWindowText(AWnd, PChar(Result), WndCaptionLen);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetwndText(Handle));
end;
// Способ второй
function GetwndText(AWnd: THandle): string;
var
WndCaption: array of Char;
WndCaptionLen: Word;
begin
WndCaptionLen := GetWindowTextLength(AWnd) + 1;
if WndCaptionLen > 1 then
begin
SetLength(WndCaption, WndCaptionLen);
GetWindowText(AWnd, @WndCaption[0], WndCaptionLen);
Result := PChar(WndCaption);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetwndText(Handle));
end;
// Способ третий
function GetwndText2(AWnd: THandle): string;
var
WndCaption: PChar;
WndCaptionLen: Word;
begin
WndCaptionLen := GetWindowTextLength(AWnd) + 1;
if WndCaptionLen > 1 then
begin
GetMem(WndCaption, WndCaptionLen);
try
SetLength(Result, WndCaptionLen);
GetWindowText(AWnd, @WndCaption[0], WndCaptionLen);
Result := WndCaption;
// или StrCopy(@Result[1], WndCaption);
// или StrLCopy(@Result[1], WndCaption, WndCaptionLen);
finally
FreeMem(WndCaption, WndCaptionLen)
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetwndText(Handle));
end;
|
|
При использовании материала - ссылка на сайт обязательна
|
|