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

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

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

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как определить, что приложение зависло?

// Способ первый
function IsAppResponding(Wnd: HWND): Boolean;
const
  TIMEOUT = 50;
var
  Res: {$IFDEF CPUX86}DWORD{$ELSE IFDEF CPUX86}PDWORD_PTR{$ENDIF};
begin
  Result := SendMessageTimeout(Wnd, WM_NULL, 0, 0,
    SMTO_NORMAL or SMTO_ABORTIFHUNG, TIMEOUT, Res) <> 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if IsAppResponding(Handle) then
    ShowMessage('Приложение не зависло')
  else
    ShowMessage('Приложение зависло');
end;

// Способ второй
// Win9X/ME
function IsAppResponding9X(dwThreadId: DWORD): Boolean;
type
  TIsHungThread = function(dwThreadId: DWORD): BOOL; stdcall;
var
  hUser32: THandle;
  IsHungThread: TIsHungThread;
begin
  Result := True;
  hUser32 := GetModuleHandle('User32.dll');
  if hUser32 > 0 then
  begin
    @IsHungThread := GetProcAddress(hUser32, 'IsHungThread');
    if Assigned(IsHungThread) then
      Result := not IsHungThread(dwThreadId);
  end;
end;

// Win NT/2000/XP
function IsAppRespondingNT(Wnd: HWND): Boolean;
type
  TIsHungAppWindow = function(Wnd: HWND): BOOL; stdcall;
var
  hUser32: THandle;
  IsHungAppWindow: TIsHungAppWindow;
begin
  Result := True;
  hUser32 := GetModuleHandle('User32.dll');
  if hUser32 > 0 then
  begin
    @IsHungAppWindow := GetProcAddress(hUser32, 'IsHungAppWindow');
    if Assigned(IsHungAppWindow) then
      Result := not IsHungAppWindow(Wnd);
  end;
end;

function IsAppRespondig(Wnd: HWND): Boolean;
begin
  if not IsWindow(Wnd) then
  begin
    ShowMessage('Неверный идентификатор');
    Exit;
  end;

  if Win32Platform = VER_PLATFORM_WIN32_NT then
    Result := IsAppRespondingNT(Wnd)
  else
    Result := IsAppResponding9X(GetWindowThreadProcessId(Wnd, nil));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Res: DWORD;
begin
  if IsAppResponding(Handle) then
    ShowMessage('Приложение не зависло')
  else
    ShowMessage('Приложение зависло');
end;


Как определить состояние формы Normal/Minimized/Maximized?

// Способ первый
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  case WindowState of
    wsNormal: Caption := 'Normal';
    wsMinimized: Caption := 'Minimized';
    wsMaximized: Caption := 'Maximized';
  end;
end;

// Способ второй
procedure TForm1.Timer1Timer(Sender: TObject);
var
  wp: TWindowPlacement;
begin
  wp.length := SizeOf(TWindowPlacement);
  GetWindowPlacement(Handle, @wp);
  case wp.showCmd of
    SW_NORMAL: Caption := 'Normal';
    SW_SHOWMINIMIZED: Caption := 'Minimized';
    SW_SHOWMAXIMIZED: Caption := 'Maximized';
  end;
end;


Как определить "оригинальные" (wsNormal) размеры формы?

procedure TForm1.Button1Click(Sender: TObject);
var
  wp: TWindowPlacement;
  r: Trect;
begin
  if WindowState = wsMaximized then
  begin
    wp.length := SizeOf(TWindowPlacement);
    GetWindowPlacement(Handle, @wp);
    R := wp.rcNormalPosition;
  end
  else
    GetWindowRect(Handle, r);

  ShowMessage(Format('Left: %d'#13'Top: %d'#13'Right: %d'#13'Bottom: %d',
                     [r.Left, r.Top, r.Right, r.Bottom]));
end;


Как скрыть главное окно приложения при старте?

// В dpr файле проекта пишем
begin
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm1, Form1);
  Application.ShowMainForm := False; // <--
  Application.Run;
end.


Как не дать приложению развернуться из иконки?

type
  TForm1 = class(TForm)
  private
    procedure WMQueryOpen(var Msg: TWMQueryOpen); message WM_QUERYOPEN;
    {...}
  end;

implementation

procedure TForm1.WMQueryOpen(var Msg: TWMQueryOpen);
begin
  Msg.Result := 0;
end;


Как получить хендл предыдущего активнго окна?

procedure TForm1.Button1Click(Sender: TObject);

  function GetPrevWindowHandle: HWND;
  begin
    Result := GetWindow(Application.Handle, GW_HWNDPREV);
  end;

var
  Buf: array[0..255] of Char;
begin
  GetWindowText(GetPrevWindowHandle, Buf, SizeOf(Buf));
  ShowMessage(StrPas(Buf));
end;


Как запретить окну переходить в прозрачный режим при нажатии клавишь Win+Space?

type
  TForm1 = class(TForm)
  {...}
  protected
    procedure CreateHandle; override;
    {...}
  end;

implementation

uses
  {...,} Winapi.DwmApi;

procedure TForm1.CreateHandle;
const
  Val: Integer = DWMWA_ALLOW_NCPAINT;
var
  Res: Integer;
begin
  inherited CreateHandle;

  Res := DwmSetWindowAttribute(Handle, DWMWA_EXCLUDED_FROM_PEEK, @Val, SizeOf(Val));
  {$IFDEF DEBUG}
  if Res <> S_OK then
    ShowMessage(SysErrorMessage(Res));
  {$ENDIF}
end;


Как убрать окно из обработки Flip3D (трехмерный переключатель окон, вызываемый комбинацией Win+Tab)?

type
  TForm1 = class(TForm)
  {...}
  protected
    procedure CreateHandle; override;
    {...}
  end;

implementation

uses
  {...,} Winapi.DwmApi;

procedure TForm1.CreateHandle;
const
  Val: Integer = DWMFLIP3D_EXCLUDEABOVE; // DWMFLIP3D_EXCLUDEBELOW;
var
  Res: Integer;
begin
  inherited CreateHandle;

  Res := DwmSetWindowAttribute(Handle, DWMWA_FLIP3D_POLICY, @Val, SizeOf(Val));
  {$IFDEF DEBUG}
  if Res <> S_OK then
    ShowMessage(SysErrorMessage(Res));
  {$ENDIF}
end;


Как получить путь к исполняемому файлу?

// Способ первый
function GetExeFileName: string;
var
  Buffer: array[0..MAX_PATH] of Char;
begin
  SetString(Result, Buffer,
    GetModuleFileName(HInstance, Buffer, SizeOf(Buffer)));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetExeFileName);
end;

// Способ второй
function GetExeFileName: string;
begin
  Result := Application.ExeName;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetExeFileName);
end;

// Способ третий
function GetExeFileName: string;
begin
  Result := ParamStr(0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetExeFileName);
end;


Как заставить окно всегда рисоваться (не)активным?

type
  TForm32 = class(TForm)
  private
    procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCACTIVATE;
  public
    { Public declarations }
  end;

var
  Form32: TForm32;

implementation

{$R *.dfm}

{ TForm32 }

procedure TForm32.WMNCActivate(var Msg: TWMNCActivate);
begin
  // True - всегда активно
  // False - всегда неактивно
  Msg.Active := True;
  inherited;
end;

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