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;

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