Программирование на Delphi

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

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как сделать, чтобы при минимизации (свертывании), программа исчезала из таскбара?


// Добавьте в описание формы:
type
  TMain = class(TForm)
  {...}
  protected
    procedure WMGetSysCommand(var Message: TMessage); message WM_SYSCOMMAND;
  end;

{...}

// Обработка сообщения WM_SYSCOMMAND
// перехват минимизации окна
procedure TForm1.WMGetSysCommand( var Message: TMessage );
begin
  if Message.wParam = SC_MINIMIZE then
    form1.Visible := False
  else
    inherited;
end;

Как перетащить форму за ее поле?


// Способ первый. Его лучше применять в том случае,
// если Form1.BorderStyle = bsNone, так как на кнопки
// минимизации, максимизации и закрытия окна
// вы нажать не сможете.
type
  TForm1 = class(TForm)
  private
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    {...}
  end;

{...}

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
  inherited;
  Msg.Result := HTCAPTION;
end;

// Способ второй. Его приемущество в том, что его
// можно применить не только к форме, но и к любому
// компоненту, например к панели. Выше указанная
// проблема отсутствует.
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
const
  SC_DragMove = $F012;
begin
  ReleaseCapture;
  Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);
end;

// Способ третий
type
  TForm1 = class(TForm)
  private
    { Private declarations }
    Draging: Boolean;
    X0, Y0: Integer;
    {...}
  end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Draging := True;
  x0 := x;
  y0 := y;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Draging := False;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if Draging then
  begin
    Form1.Left := Form1.Left + X - X0;
    Form1.top := Form1.top + Y - Y0;
  end;
end;

Как убрать у формы системное меню?


procedure TForm1.FormCreate(Sender: TObject);
var
  Style: Longint;
begin
  Style := GetWindowLong(Handle, GWL_STYLE);
  SetWindowLong(Handle, GWL_STYLE, Style and not WS_SYSMENU);
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if ssAlt in Shift then
    if Key = VK_F4 then
      Key := 0;
end;

Как ограничить размер растяжения/сжатия формы?


// Способ первый
type
  TForm1 = class(TForm)
  {...}
  private
    procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
  end;

procedure TForm1.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
begin
  inherited;
  // минимальный размер формы
  Msg.MinMaxInfo^.ptMinTrackSize := Point(158, 177);
  // максимальный размер формы
  Msg.MinMaxInfo^.ptMaxTrackSize := Point(350, 350);
end;

// Способ второй
type
  TForm1 = class(TForm)
  {...}
  private
    procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
  end;

procedure TForm1.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
begin
  inherited;
  Msg.MinMaxInfo^.ptMinTrackSize.X := 400;
  Msg.MinMaxInfo^.ptMinTrackSize.Y := 300;
  Msg.MinMaxInfo^.ptMaxTrackSize.X := 600;
  Msg.MinMaxInfo^.ptMaxTrackSize.Y := 450;
end;

// Способ третий
procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Constraints.MaxHeight := 600;
  Form1.Constraints.MaxWidth := 800;
  Form1.Constraints.MinHeight := 400;
  Form1.Constraints.MinWidth := 600;
end;

Как затенить кнопку "закрыть" в заголовке формы?


// Способ первый
procedure TForm1.FormCreate(Sender: TObject);
var
  hwndHandle: THandle;
  hMenuHandle: HMENU;
  iPos: Integer;
begin
  hwndHandle := FindWindow(nil, PChar(Caption));
  if hwndHandle <> 0 then
  begin
    hMenuHandle := GetSystemMenu(hwndHandle, False);
    if hMenuHandle <> 0 then
    begin
      DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
      iPos := GetMenuItemCount(hMenuHandle);
      Dec(iPos);
      // Нужно быть уверенным, что нет ошибки т.к. -1 указывает на ошибку
      if iPos > -1 then
        DeleteMenu(hMenuHandle, iPos, MF_BYPOSITION);
    end;
  end;
end;

// Отрубаем Alt+F4
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (ssAlt in Shift) and (Key = VK_F4) then
    Key := 0;
end;

// Способ второй
procedure TForm1.FormCreate(Sender: TObject);
var
  SysMenu: HMENU;
begin
  SysMenu := GetSystemMenu(Handle, False);
  Windows.EnableMenuItem(SysMenu, SC_CLOSE, MF_DISABLED or MF_GRAYED);
  GetSystemMenu(Handle, False);
  Perform(WM_NCPAINT, Handle, 0);
end;

// Отрубаем Alt+F4
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if ssAlt in Shift then
   if Key = VK_F4 then
      Key := 0;
end;

// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
begin
  SetClassLong(Handle, GCL_STYLE, GetClassLong(Handle, GCL_STYLE) or CS_NOCLOSE);
  // Вернуть обратно
  // SetClassLong(Handle, GCL_STYLE, GetClassLong(Handle, GCL_STYLE) and not CS_NOCLOSE);
end;

Как запретить запуск второй копии программы?


// Способ первый
procedure TForm1.FormCreate(Sender: TObject);
var
  Wnd: HWND;
begin
  Wnd := CreateMutex(nil, True , PChar(Application.title));
  if GetLastError = ERROR_ALREADY_EXISTS then
  begin
    CloseHandle(Wnd);
    Application.Terminate;
  end;
end;

// Способ второй
procedure TForm1.FormCreate(Sender: TObject);
var
  Wnd: HWND;
  buff: array [0..127] of Char;
begin
  Wnd := GetWindow(Handle, GW_HWNDFIRST);
  while Wnd <> 0 do
  begin
    // Если не собственное и не дочернее окно
    if (Wnd <> Application.Handle) and (GetWindow(Wnd, GW_OWNER) = 0) then
    begin
      GetWindowText(Wnd, buff, SizeOf(buff));
      // Если заголовок совпадает, то...
      if StrPas(buff) = Application.Title then // Повторный запуск
      begin
        // Действие при повторном запуске
        CloseHandle(Wnd);
        Application.Terminate;
      end;
    end;
    Wnd := GetWindow(Wnd, GW_HWNDNEXT);
  end;
end;

// Способ третий
// Приведите файл *.dpr к следующему виду
program Project1;

uses
  Forms, Windows,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

var
  HWND: THandle;

function Check: Boolean;
begin
  HWND := OpenMutex(MUTEX_ALL_ACCESS, False, 'MyOwnMutex');
  Result := HWND <> 0;
  if HWND = 0 then
    HWND := CreateMutex(nil, False, 'MyOwnMutex');
end;

begin
  if Check then
    Exit;

  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

// Способ четвертый
// Приведите файл *.dpr к следующему виду
program Project1;

uses
  Forms, SyncObjs,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

var
  CheckEvent: TEvent;

begin
  CheckEvent:= TEvent.Create(nil, False, True, 'MYPROGRAM_CHECKEXIST');
  if CheckEvent.WaitFor(10) <> wrSignaled then
    Exit;

  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

// Способ пятый
// Необходимо быть уверенным, что в системе больше нет окон с именем "TForm1"
// Приведите файл *.dpr к следующему виду
program Project1;

uses
  Forms, Windows,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

var
  hwnd: THandle;

begin
  hwnd := FindWindow('TForm1', 'Form1');
  if hwnd = 0 then
  begin
    Application.Initialize;
    Application.CreateForm(TForm1, Form1);
    Application.Run;
  end
  else
    SetForegroundWindow(hwnd);
end.

// Способ шестой
// Приведите файл *.dpr к следующему виду
program Project1;

uses
  Forms, Windows,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

const
  MemFileSize = 127;
  MemFileName = 'one_example';

var
  MemHnd: HWND;

begin
  MemHnd := CreateFileMapping(HWND($FFFFFFFF), nil,
    PAGE_READWRITE, 0, MemFileSize, MemFileName);
  if GetLastError <> ERROR_ALREADY_EXISTS then
  begin
     Application.Initialize;
     with TForm1.Create(nil) do
     try
       Show;
       Update;
       Application.CreateForm(TForm1, Form1);
     finally
       Free;
     end;
     Application.Run;
  end
  else
    Application.MessageBox('Приложение уже запущено',
                           'Производственно-диспетчерская служба', MB_OK);
  CloseHandle(MemHnd);
end.

Как создать мигающий заголовок окна (пиктограмму)?


// Способ первый
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  // Чтобы мигал заголовок формы
  FlashWindow(Form1.Handle, True);
  // Чтобы мигала пиктограмма в TaskBar
  FlashWindow(Application.Handle, True);
end;

// Способ второй
procedure FlashWnd(h: HWND; active: Boolean);
var
  fl: TFlashWInfo;
begin
  fl.cbSize := SizeOf(TFlashWInfo);
  fl.uCount := INFINITE; // Или необходимое количество повторений
  fl.dwTimeout := 500; // Интервал
  fl.hwnd := h;
  if active then
    fl.dwFlags := FLASHW_ALL
  else
    fl.dwFlags := FLASHW_STOP;
  FlashWindowEx(fl);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FlashWnd(Application.MainForm.Handle, True);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  FlashWnd(Application.MainForm.Handle, False);
end;

Как создать форму без заголовка?


// Способ первый
procedure TForm1.FormCreate(Sender: TObject);
begin
  SetWindowLong(Handle, GWL_STYLE,
    GetWindowLong(Handle, GWL_STYLE) and not WS_CAPTION);
  Height := ClientHeight;
  Width := ClientWidth;
end;

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

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    Style := (Style or WS_POPUP) and not WS_DLGFRAME;
end;

// Способ третий
type
  TForm1 = class(TForm)
  private
    procedure CreateParams(var Params : TCreateParams); override;
    {...}
  end;

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := WS_THICKFRAME or WS_POPUP or WS_BORDER;
end;

Как сделать, чтобы форма всегда была поверх других форм?


// Поверх всех окон
procedure TForm1.Button1Click(Sender: TObject);
begin
  SetWindowPos(Handle, HWND_TOPMOST, Left, Top, Width, Height,
               SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
end;

// Отменить
procedure TForm1.Button1Click(Sender: TObject);
begin
  SetWindowPos(Handle, HWND_NOTOPMOST, Left, Top, Width, Height,
               SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
end;

Как скрыть пиктограмму своей формы на TaskBar?


// Способ первый
procedure TForm1.FormShow(Sender: TObject);
begin
  ShowWindow(Application.Handle, SW_HIDE);
end;
// Для восстановления используйте команду
// ShowWindow(Application.Handle, SW_RESTORE);

// Способ второй
// Приведите файл *.dpr к следующему виду
program Project1;

uses
  Forms,
  Windows,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

var
  EStyle: Integer;

begin
  Application.Initialize;
  EStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE);
  SetWindowLong(Application.Handle, GWL_EXSTYLE, EStyle or WS_EX_TOOLWINDOW);
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

// Способ третий
uses
  ShlObj, ActiveX;

// Скрыть пиктограмму
procedure TForm1.Button1Click(Sender: TObject);
var
  Tb: ITaskbarList;
begin
  if Succeeded(CoCreateInstance(CLSID_TaskbarList, nil, CLSCTX_INPROC_SERVER, IID_ITaskbarList, Tb)) then
  begin
    Tb.HrInit;
    Tb.DeleteTab(Application.MainForm.Handle);
  end;
end;

// Показать пиктограмму
procedure TForm1.Button2Click(Sender: TObject);
var
  Tb: ITaskbarList;
begin
  if Succeeded(CoCreateInstance(CLSID_TaskbarList, nil, CLSCTX_INPROC_SERVER, IID_ITaskbarList, Tb)) then
  begin
    Tb.HrInit;
    Tb.AddTab(Application.MainForm.Handle);
    Tb.ActivateTab(Application.MainForm.Handle);
  end;
end;

// Способ четвертый
// Не рекомендуется к использованию в виду того, что системе сложно обрабатывать связи
// между процессами. Некоторые межпроцессовые сообщения могут быть вовсе заблокированы.
procedure TForm1.Button1Click(Sender: TObject);
begin
  // Если в качестве родительского окна указан рабочий стол,
  // то программа убирается из панели задач.
  SetWindowLong(Application.MainForm.Handle, GWL_HWNDPARENT, GetDesktopWindow);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  // Если у главного окна приложения нет родительского окна,
  // то оно отображается на панели задач.
  SetWindowLong(Application.MainForm.Handle, GWL_HWNDPARENT, 0);
end;

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