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;

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