FAQ VCL
MDI приложение

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

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

:: MVP ::

:: RSS ::

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

Как скрывать свернутые дочерние формы в MDI приложении?

// Способ первый
// В код MDIChild формы нужно добавить следующее
type
  TForm2 = class(TForm)
  {...}
  public
    { Public declarations }
    procedure WMSize(var Msg: TWMSIZE); message WM_SIZE;
  {...}
  end;

implementation

procedure TForm2.WMSize(var Msg: TWMSIZE);
begin
  inherited;
  if Msg.SizeType = SIZE_MINIMIZED then
    if Msg.SizeType = SIZE_MINIMIZED then
      ShowWindow(Handle, SW_HIDE);
end;

// Способ второй
// В код MDIChild формы нужно добавить следующее
type
  TForm2 = class(TForm)
  private
    procedure WMSize(var Msg: TWMSIZE); message WM_SIZE;
  protected
    procedure VisibleChanging; override;
    {...}
  end;

implementation

procedure TForm2.VisibleChanging;
begin
end;

procedure TForm2.WMSize(var Msg: TWMSIZE);
begin
  inherited;
  if Visible then // Чтобы форма не скрытась при создании
    if Msg.SizeType = SIZE_MINIMIZED then
      Visible := False;
end;

// Способ третий
// В код MDIChild формы нужно добавить следующее
type
  TForm2 = class(TForm)
    procedure FormShow(Sender: TObject);
  public
    procedure DefaultHandler(var Message); override;
    {...}
  end;

implementation   

procedure TForm2.DefaultHandler(var Message);
begin
  inherited;
  if TMessage(Message).Msg = WM_SIZE then
    if TMessage(Message).WParam = SIZE_MINIMIZED then
      Visible := False;
end;

procedure TForm2.FormShow(Sender: TObject);
begin
  Parent := Application.MainForm;
end;


Как закрыть дочернюю форму?

procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;


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

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

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

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style and (not WS_CAPTION);
end;


Как скрыть/показать скроллы в MDI форме?

implementation

{$R *.dfm}

var
  flag: boolean = false;

function ClientWindowProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall;
var
  f: Pointer;
begin
  f := Pointer(GetWindowLong(Wnd, GWL_USERDATA));
  case Msg of
    WM_NCCALCSIZE:  begin
      // flag = false - скрыть полосы прокрутки; flag = true - показать полосы прокрутки;
      if not flag then
      begin
        if (GetWindowLong(Wnd, GWL_STYLE) and (WS_HSCROLL or WS_VSCROLL)) <> 0 then
            SetWindowLong(Wnd, GWL_STYLE, GetWindowLong(Wnd, GWL_STYLE) and
                          not (WS_HSCROLL or WS_VSCROLL));
      end
      else
      begin
        if (GetWindowLong(Wnd, GWL_STYLE) and (WS_HSCROLL or WS_VSCROLL)) = 0 then
            SetWindowLong(Wnd, GWL_STYLE, GetWindowLong(Wnd, GWL_STYLE) or
                          (WS_HSCROLL or WS_VSCROLL));
      end;
    end;
  end;
  Result := CallWindowProc(f, Wnd, Msg, wParam, lParam);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if ClientHandle <> 0 then
  begin
    if GetWindowLong(ClientHandle, GWL_USERDATA) <> 0 then
      Exit;
    SetWindowLong(ClientHandle, GWL_USERDATA, SetWindowLong(ClientHandle,
                  GWL_WNDPROC, integer(@ClientWindowProc)));
  end;
end;


Как заставить корректно работать скроллы MDIForm при перетаскивании дочернего окна?

// Способ первый
var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  WndProcHook: HHook;

function CallWndHook(Code: Integer; WParam: wParam; Msg: PCWPStruct): LongInt; stdcall;
var
  VertMin, VertMax, HorzMin, HorzMax: Integer;
begin
  case Msg^.message of
    WM_MOVE:  begin
      GetScrollRange(Form1.ClientHandle, SB_HORZ, HorzMin, HorzMax);
      GetScrollRange(Form1.ClientHandle, SB_VERT, VertMin, VertMax);
      SetScrollRange(Form1.ClientHandle, SB_HORZ, HorzMin, HorzMax, True);
      SetScrollRange(Form1.ClientHandle, SB_VERT, VertMin, VertMax, True);
    end;
  end;
  Result := CallNextHookEx(WndProcHook, Code, WParam, LongInt(Msg));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  WndProcHook := SetWindowsHookEx(WH_CALLWNDPROC, @CallWndHook, 0, GetCurrentThreadID);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if WndProcHook > 0 then
    UnHookWindowsHookEx(WndProcHook);
end;

// Способ второй
// MDIForm
type
  TForm1 = class(TForm)
  public
    procedure UpdateScrollBars;
  end;

var
  Form1: TForm1;

implementation

procedure TForm1.UpdateScrollBars;
var
  VertMin, VertMax, HorzMin, HorzMax: Integer;
begin
  GetScrollRange(ClientHandle, SB_HORZ, HorzMin, HorzMax);
  GetScrollRange(ClientHandle, SB_VERT, VertMin, VertMax);
  SetScrollRange(ClientHandle, SB_HORZ, HorzMin, HorzMax, True);
  SetScrollRange(ClientHandle, SB_VERT, VertMin, VertMax, True);
end;

// MDIChild
type
  TForm2 = class(TForm)
  private
    procedure WMMove(var Msg: TWMMove); message WM_MOVE;
  end;

implementation

uses
  Unit1;

procedure TForm2.WMMove(var Msg: TWMMove);
begin
  inherited;
  Form1.UpdateScrollBars;
end;


Как подменить оконную процедуру в MDI приложении?

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    MDIDefProc: pointer;
    MDIInstance: TFarProc;
    procedure MDIWndProc(var Msg: TMessage);
  public
  end;

implementation

procedure TForm1.MDIWndProc(var Msg: TMessage);
begin
  with Msg do
  begin
    if Msg = WM_MDINEXT then
    begin
      // Запрещаем перемещение между окнами по CTRL+TAB и CTRL+F6
    end
    else
      Result := CallWindowProc(MDIDefProc, ClientHandle, Msg, wParam, lParam);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  MDIInstance := MakeObjectInstance(MDIWndProc);
  MDIDefProc := Pointer(SetWindowLong(ClientHandle, GWL_WNDPROC,
    LongInt(MDIInstance)));
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(MDIDefProc));
  FreeObjectInstance(MDIInstance);
end;


Как узнать сколько открыто дочерних окон?

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('Количество MDIChild окон: ' + IntToStr(Form1.MDIChildCount));
end;


Как отключить переключение между дочерними окнами по CTRL+TAB/CTRL+F6?

function ClientWindowProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall;
var
  f: Pointer;
begin
  f := Pointer(GetWindowLong(Wnd, GWL_USERDATA));
  if Msg <> WM_MDINEXT then
    Result := CallWindowProc(f, Wnd, Msg, wParam, lParam);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if ClientHandle <> 0 then
  begin
    if GetWindowLong(ClientHandle, GWL_USERDATA) <> 0 then
      Exit;
    SetWindowLong(ClientHandle, GWL_USERDATA, SetWindowLong(ClientHandle,
                  GWL_WNDPROC, Integer(@ClientWindowProc)));
  end;
end;


Как перевести дочернюю форму в режим StayOnTop и обратно?

procedure TForm1.Button1Click(Sender: TObject);
var
  r: TRect;
begin
  if Form2.FormStyle <> fsStayOnTop then
  begin
    Form2.Tag := MakeLong(Form2.Left, Form2.Top);
    Form2.FormStyle := fsStayOnTop;
    // SetWindowLong(Form2.Handle, GWL_HWNDPARENT, Application.MainForm.Handle);
  end
  else
  begin
    GetWindowRect(Form2.Handle, r);
    Form2.FormStyle := fsMDIChild;
    MoveWindow(Form2.Handle, LoWord(Form2.Tag), HiWord(Form2.Tag), r.Width, r.Height, True);
  end;
end;

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