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

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

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

:: MVP ::

:: RSS ::

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

Как ограничить перемещение формы пределами рабочей области?

type
   TWmMoving = record
     Msg: Cardinal;
     fwSide: Cardinal;
     lpRect: PRect;
     Result: Integer;
   end;

type
  TForm1 = class(TForm)
  private
    procedure WMMoving(var Msg: TWMMoving); message WM_MOVING;
    {...}
  end;

procedure TForm1.WMMoving(var Msg: TWMMoving);
var
  WorkArea: TRect;
begin
  WorkArea := Screen.WorkareaRect;
  with Msg.DragRect^ do
  begin
    if Left < WorkArea.Left then
      OffsetRect(Msg.DragRect^, workArea.Left - Left, 0);
    if Top < WorkArea.Top then
      OffsetRect(Msg.DragRect^, 0, workArea.Top - Top);
    if Right > workArea.Right then
      OffsetRect(Msg.DragRect^, workArea.Right - Right, 0);
    if Bottom > workArea.Bottom then
      OffsetRect(Msg.DragRect^, 0, workArea.Bottom - Bottom);
  end;

  inherited;
end;


Как включить/отключить анимацию формы при сворачивании/разворачивании?

procedure SetAnimation(Value: Boolean);
var
  Info: TAnimationInfo;
begin
  ZeroMemory(@Info, SizeOf(Info));
  Info.cbSize := SizeOf(TAnimationInfo);
  BOOL(Info.iMinAnimate) := Value;
  SystemParametersInfo(SPI_SETANIMATION, SizeOf(Info), @Info, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetAnimation(False); // отключить анимацию
  // SetAnimation(True); // включить анимацию
end;


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

procedure TForm1.FormShow(Sender: TObject);
begin
  AnimateWindow(Handle, 500, AW_CENTER or AW_SLIDE or AW_ACTIVATE);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  AnimateWindow(Handle, 500, AW_BLEND or AW_HIDE or AW_ACTIVATE);
end;

// При использовании слайда или прокрутки мультипликации  необходимо задать направление.
// Это может быть или AW_HOR_POSITIVE, AW_HOR_NEGATIVE, AW_VER_POSITIVE, или AW_VER_NEGATIVE.
// Флажки AW_HOR_POSITIVE или AW_HOR_NEGATIVE можно комбинировать с AW_VER_POSITIVE или AW_VER_NEGATIVE,
// чтобы анимировать окно по диагонали.


Как вывести окно на передний план?

// Способ первый
procedure TForm1.ForegroundWnd;
var
  ID: Cardinal;
begin
  ID := GetWindowThreadProcessId(GetForegroundWindow, nil);
  AttachThreadInput(GetCurrentThreadId, ID, True);
  SetForegroundWindow(Handle);
  AttachThreadInput(GetCurrentThreadId, ID, False);
  if IsIconic(Handle) then
    ShowWindow(Handle, SW_RESTORE);
end;

// Способ второй
procedure SwitchToThisWindow(Wnd: HWND; fAltTab: Boolean);
  stdcall; external 'user32.dll' name 'SwitchToThisWindow';

implementation

procedure TForm1.Button1Click(Sender: TObject);
begin
  // SetActiveWindow(Handle);
  SwitchToThisWindow(Handle, True);
end;


Как проверить имеет ли окно стиль WS_EX_TOPMOST (поверх всех окон)?

function IsWindowTopMost(Wnd: HWND): Boolean;
var
  Style: Integer;
begin
  Style := GetWindowLong(Wnd, GWL_EXSTYLE);
  Result := (Style and WS_EX_TOPMOST) = WS_EX_TOPMOST;
end;


Как перебрать все окна в z-порядке, начиная с верхнего?

procedure GetList(Memo: TMemo);

  function GetDesctopHandle: HWND;
  begin
    Result := FindWindow('Progman', 'Program Manager');
    Result := FindWindowEx(Result, HWND(nil), 'SHELLDLL_DefView', '');
    Result := FindWindowEx(Result, HWND(nil), 'SysListView32', '');
  end;

var
  w: HWND;
  buff: array [0..MAX_PATH] of Char;
begin
  Memo.Clear;

  // Получаем окно на вершине z-порядка
  w := GetTopWindow(GetDesctopHandle);
  while w > 0 do
  begin
    {if w <> Form1.Handle then} // Можно пропустить собственное окно
      if IsWindowVisible(w) and
        // Пропускаем окне без заголовков
        (GetWindowText(w, buff, SizeOf(buff)) <> 0)
        {and not IsIconic(w)} then
      begin
        GetWindowText(w, buff, SizeOf(buff));
        Memo.Lines.Add(StrPas(buff) + #9 + IntToStr(w));
      end;
    w := GetNextWindow(w, GW_HWNDNEXT);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GetList(Memo1);
end;


Как сделать, чтобы программа запускалась только один раз за сессию Windows?

procedure TForm1.FormCreate(Sender: TObject);
var
  CRLF: string;
begin
  if GlobalFindAtom('THIS_IS_SOME_OBSCUREE_TEXT') = 0 then
    GlobalAddAtom('THIS_IS_SOME_OBSCUREE_TEXT')
  else
  begin
    CRLF := #10 + #13;
    ShowMessage('Эта версия прогаммы может быть запущена ' +
                'только один раз за сессию Windows.' + CRLF +
                'Чтобы запустить программу снова, ' +
                'вам нужно перезагрузить Windows, или' + CRLF +
                'Зарегистрироваться !!!');
    Halt;
  end;
end;


Как сделать, чтобы форма отбрасывала тень?

// Это хорошо смотрится в Win2000/XP, в Vista/7 лучше не использовать

procedure TForm1.FormCreate(Sender: TObject);
const
  CS_DROPSHADOW = $20000; // Могут быть и другие значения - $20001, $20005, ...
begin
  SetClassLong(Handle, GCL_STYLE, GetWindowLong(Handle, GCL_STYLE) or CS_DROPSHADOW);
end;


Как запретить переход фокуса при нажатии клавиши TAB?

type
  TForm1 = class(TForm)
  private
    procedure CMDialogKey(var Msg: TWMKey); message CM_DIALOGKEY;
  end;

procedure TForm1.CMDialogKey(var Msg: TWMKey);
begin
  // При желании для определенных компонентов можно сделать исключение
  // if not (ActiveControl is TButton) then
  if Msg.Charcode = VK_TAB then
    Msg.Charcode := 0;
  inherited;
end;


Как изменить размер формы, не имеющей границ?

// Способ первый
type
  TForm1 = class(TForm)
  private
    procedure HitTest(var Msg: TWMNcHitTest); message WM_NCHITTEST;
  end;

{...}

implementation

{...}

procedure TForm1.HitTest(var Msg: TWMNcHitTest);
var
  x, y: Integer;
begin
  inherited;

  x := Msg.XPos - Left;
  y := Msg.YPos - Top;

  if x <= 4 then
  begin
    if y <= 4 then
      Msg.Result := HTTOPLEFT
    else
      if y >= ClientHeight - 4 then
        Msg.Result := HTBOTTOMLEFT
      else
        Msg.Result := HTLEFT;
  end
  else
  if y <= 4 then
  begin
    if x >= ClientWidth - 4 then
      Msg.Result := HTTOPRIGHT
    else
      Msg.Result := HTTOP;
  end
  else
  if y >= ClientHeight - 4 then
  begin
    if x >= ClientWidth - 4 then
      Msg.Result := HTBOTTOMRIGHT
    else
      Msg.Result := HTBOTTOM;
  end
  else
    if x >= ClientWidth - 4 then
      Msg.Result := HTRIGHT
    else
      Msg.Result := HTCAPTION;
end;

// Способ второй
type
  TForm1 = class(TForm)
  public
    procedure CreateParams(var Params: TCreateParams); override;
  end;

{...}

implementation

{...}

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or WS_SIZEBOX;
  // Params.ExStyle:= Params.ExStyle or WS_EX_STATICEDGE
end;

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