FAQ VCL
Форма (приложение)

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: 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;

При использовании материала - ссылка на сайт обязательна