Фон MDI-окон

Привожу код, который может оказаться полезным. Он позволяет в обычной или MDI-форме создать графический tile-фон или градиентную заливку.

(Tile - "секция, плитка" - непрерывное заполнение определенной области немасштабируемым изображением слева-направо сверху вниз - В.О.)

Самая сложная часть кода осуществляет обработку системного сообщения, адресуемого дескриптору окна (ClientHandle), осуществляющему управление дочерними формами. Происходит это в момент вывода изображений в MDI-форме. Все что вам необходимо сделать - в режиме проектирования загрузить в imgTile необходимые изображения и перенести в свою программу следующий код:

Code:

unit UMain;

interface

uses

Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms,

Dialogs, ExtCtrls, Menus;

type

TfrmMain = class(TForm)

mnuMain: TMainMenu;

mnuFile: TMenuItem;

mnuExit: TMenuItem;

imgTile: TImage;

mnuOptions: TMenuItem;

mnuBitmap: TMenuItem;

mnuGradient: TMenuItem;

procedure mnuExitClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure mnuBitmapClick(Sender: TObject);

procedure mnuGradientClick(Sender: TObject);

procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

procedure FormResize(Sender: TObject);

procedure FormPaint(Sender: TObject);

private

{ Private declarations }

MDIDefProc: pointer;

MDIInstance: TFarProc;

procedure MDIWndProc(var prmMsg: TMessage);

procedure CreateWnd; override;

procedure ShowBitmap(prmDC: hDC);

procedure ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);

public

{ Public declarations }

end;

var

frmMain: TfrmMain;

glbImgWidth: integer;

glbImgHeight: integer;

implementation

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);

begin

glbImgHeight := imgTile.Picture.Height;

glbImgWidth := imgTile.Picture.Width;

end;

procedure TfrmMain.FormResize(Sender: TObject);

begin

FormPaint(Sender);

end;

procedure TfrmMain.MDIWndProc(var prmMsg: TMessage);

begin

with prmMsg do

begin

if Msg = WM_ERASEBKGND then

begin

if mnuBitmap.Checked then

ShowBitmap(wParam)

else

ShowGradient(wParam, 255, 0, 0);

Result := 1;

end

else

Result := CallWindowProc(MDIDefProc, ClientHandle, Msg, wParam, lParam);

end;

procedure TfrmMain.CreateWnd;

begin

inherited CreateWnd;

MDIInstance := MakeObjectInstance(MDIWndProc); { создаем ObjectInstance }

MDIDefProc := pointer(SetWindowLong(ClientHandle, GWL_WNDPROC,

longint(MDIInstance)));

end;

procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose:

Boolean);

begin

{ восстанавоиваем proc окна по умолчанию }

SetWindowLong(ClientHandle, GWL_WNDPROC, longint(MDIDefProc));

{ избавляемся от ObjectInstance }

FreeObjectInstance(MDIInstance);

end;

procedure TfrmMain.mnuExitClick(Sender: TObject);

begin

close;

end;

procedure TfrmMain.mnuBitmapClick(Sender: TObject);

var

wrkDC: hDC;

begin

wrkDC := GetDC(ClientHandle);

ShowBitmap(wrkDC);

ReleaseDC(ClientHandle, wrkDC);

mnuBitmap.Checked := true;

mnuGradient.Checked := false;

end;

procedure TfrmMain.mnuGradientClick(Sender: TObject);

var

wrkDC: hDC;

begin

wrkDC := GetDC(ClientHandle);

ShowGradient(wrkDC, 0, 0, 255);

ReleaseDC(ClientHandle, wrkDC);

mnuGradient.Checked := true;

mnuBitMap.Checked := false;

end;

procedure TfrmMain.ShowBitmap(prmDC: hDC);

var

wrkSource: TRect;

wrkTarget: TRect;

wrkX: integer;

wrkY: integer;

begin

{ заполняем (tile) окно изображением }

if FormStyle = fsNormal then

begin

wrkY := 0;

while wrkY < ClientHeight do { заполняем сверху вниз.. }

begin

wrkX := 0;

while wrkX < ClientWidth do { ..и слева направо. }

begin

Canvas.Draw(wrkX, wrkY, imgTile.Picture.Bitmap);

Inc(wrkX, glbImgWidth);

end;

Inc(wrkY, glbImgHeight);

end;

end

else if FormStyle = fsMDIForm then

begin

Windows.GetClientRect(ClientHandle, wrkTarget);

wrkY := 0;

while wrkY < wrkTarget.Bottom do

begin

wrkX := 0;

while wrkX < wrkTarget.Right do

begin

BitBlt(longint(prmDC), wrkX, wrkY, imgTile.Width, imgTile.Height,

imgTile.Canvas.Handle, 0, 0, SRCCOPY);

Inc(wrkX, glbImgWidth);

end;

Inc(wrkY, glbImgHeight);

end;

procedure TfrmMain.ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);

var

wrkBrushNew: hBrush;

wrkBrushOld: hBrush;

wrkColor: TColor;

wrkCount: integer;

wrkDelta: integer;

wrkRect: TRect;

wrkSize: integer;

wrkY: integer;

begin

{ процедура заполнения градиентной заливкой }

wrkDelta := 255 div (1 + ClientHeight); { желаемое количество оттенков }

if wrkDelta = 0 then

wrkDelta := 1; { да, обычно 1 }

wrkSize := ClientHeight div 240; { размер смешанных баров }

if wrkSize = 0 then

wrkSize := 1;

for wrkY := 0 to 1 + (ClientHeight div wrkSize) do

begin

wrkColor := RGB(prmRed, prmGreen, prmBlue);

wrkRect := Rect(0, wrkY * wrkSize, ClientWidth, (wrkY + 1) * wrkSize);

if FormStyle = fsNormal then

begin

Canvas.Brush.Color := wrkColor;

Canvas.FillRect(wrkRect);

end

else if FormStyle = fsMDIForm then

begin

wrkBrushNew := CreateSolidBrush(wrkColor);

wrkBrushOld := SelectObject(prmDC, wrkBrushNew);

FillRect(prmDC, wrkRect, wrkBrushNew);

SelectObject(prmDC, wrkBrushOld);

DeleteObject(wrkBrushNew);

end;

if prmRed > wrkDelta then

Dec(prmRed, wrkDelta);

if prmGreen > wrkDelta then

Dec(prmGreen, wrkDelta);

if prmBlue > wrkDelta then

Dec(prmBlue, wrkDelta);

end;

procedure TfrmMain.FormPaint(Sender: TObject);

begin

if FormStyle = fsNormal then

if mnuBitMap.Checked then

mnuBitMapClick(Sender)

else

mnuGradientClick(Sender);

end;

end.

Сначала установите свойство формы FormStyle в fsMDIForm. Затем разместите Image на форме и загрузите в него картинку. Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки:

Добавьте следующие строки в разделе implementation:

По созданию окна [событие OnCreate()] напишите такой код:

Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild

Несколько людей уже спрашивали, как залить фон главной MDI-формы повторяющимся изображением. Ключевым моментом здесь является работа с дескриптором окна MDI-клиента (свойство ClientHandle) и заполнение изображением окно клиента в ответ на сообщение WM_ERASEBKGND. Тем не менее здесь существует пара проблем: прокрутка главного окна и перемещение дочернего MDI-окна за пределы экрана портят фон, и закрашивание за иконками дочерних окон не происходит.

Ну наконец-то! Похоже я нашел как решить обе проблемы. Вот код для тех, кому все это интересно. Я начинаю с проблемы дочерних форм, ниже код для решения проблемы с главной формой (модули с именами MDIWAL2U.PAS и MDIWAL1U.PAS). На главной форме расположен компонент TImage с именем Image1, содержащий изображение для заливки фона.

Code:

...

private

{ Private declarations }

procedure WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);

message WM_ICONERASEBKGND;

...

USES MdiWal1u;

procedure TForm2.WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);

begin

TForm1(Application.Mainform).PaintUnderIcon(Self, Message.DC);

Message.Result := 0;

end;

...

{ Private declarations }

bmW, bmH: Integer;

FClientInstance,

FPrevClientProc: TFarProc;

procedure ClientWndProc(var Message: TMessage);

public

procedure PaintUnderIcon(F: TForm; D: hDC);

...

procedure TForm1.PaintUnderIcon(F: TForm; D: hDC);

var

DestR, WndR: TRect;

Ro, Co,

xOfs, yOfs,

xNum, yNum: Integer;

begin

{вычисляем необходимое число изображений для заливки D}

GetClipBox(D, DestR);

with DestR do

begin

xNum := Succ((Right - Left) div bmW);

yNum := Succ((Bottom - Top) div bmW);

end;

{вычисление смещения изображения в D}

GetWindowRect(F.Handle, WndR);

with ScreenToClient(WndR.TopLeft) do

begin

xOfs := X mod bmW;

yOfs := Y mod bmH;

end;

for Ro := 0 to xNum do

for Co := 0 to yNum do

BitBlt(D, Co * bmW - xOfs, Ro * bmH - Yofs, bmW, bmH,

Image1.Picture.Bitmap.Canvas.Handle,

0, 0, SRCCOPY);

end;

procedure TForm1.ClientWndProc(var Message: TMessage);

var

Ro, Co: Word;

begin

with Message do

case Msg of

WM_ERASEBKGND:

begin

for Ro := 0 to ClientHeight div bmH do

for Co := 0 to ClientWIDTH div bmW do

BitBlt(TWMEraseBkGnd(Message).DC,

Co * bmW, Ro * bmH, bmW, bmH,

Image1.Picture.Bitmap.Canvas.Handle,

0, 0, SRCCOPY);

Result := 1;

end;

WM_VSCROLL,

WM_HSCROLL:

begin

Result := CallWindowProc(FPrevClientProc,

ClientHandle, Msg, wParam, lParam);

InvalidateRect(ClientHandle, nil, True);

end;

else

Result := CallWindowProc(FPrevClientProc,

ClientHandle, Msg, wParam, lParam);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

bmW := Image1.Picture.Width;

bmH := Image1.Picture.Height;

FClientInstance := MakeObjectInstance(ClientWndProc);

FPrevClientProc := Pointer(

GetWindowLong(ClientHandle, GWL_WNDPROC));

SetWindowLong(ClientHandle, GWL_WNDPROC,

LongInt(FClientInstance));

end;

В разделе Заполнение изображением MDI-формы повторяющимся изображением. Я нашел (Copyright не мой а из книжки) более простой способ.

Code:

...

private

OutCanvas: TCanvas;

OldWinProc, NewWinProc: Pointer;

procedure NewWinProcedure(var Msg: TMessage);

...

procedure TMainForm.FormCreate(Sender: TObject);

begin

NewWinProc := MakeObjectInstance(NewWinProcedure);

OldWinProc := Pointer(SetWindowLong(ClientHandle,

gwl_WndProc, Cardinal(NewWinProc)));

OutCanvas := TCanvas.Create;

end;

procedure TMainForm.NewWinProcedure(var Msg: TMessage);

var

BmpWidth, BmpHeight: Integer;

I, J: Integer;

begin

// default processing first

Msg.Result := CallWindowProc(OldWinProc,

ClientHandle, Msg.Msg, Msg.wParam, Msg.lParam);

// handle background repaint

if Msg.Msg = wm_EraseBkgnd then

begin

BmpWidth := MainForm.Image1.Width;

BmpHeight := MainForm.Image1.Height;

if (BmpWidth <> 0) and (BmpHeight <> 0) then

begin

OutCanvas.Handle := Msg.wParam;

for I := 0 to MainForm.ClientWidth div BmpWidth do

for J := 0 to MainForm.ClientHeight div BmpHeight do

OutCanvas.Draw(I * BmpWidth, J * BmpHeight,

MainForm.Image1.Picture.Graphic);

end;

procedure TMainForm.FormDestroy(Sender: TObject);

begin

OutCanvas.Free;

end;

Code:

type

.... = class(TForm)

....

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

....

private

FHBrush: HBRUSH;

FCover: TBitmap;

FNewClientInstance: TFarProc;

FOldClientInstance: TFarProc;

procedure NewClientWndProc(var Message: TMessage);

....

protected

....

procedure CreateWnd; override;

....

end;

.....

implementation

{$R myRes.res} //pесуpс с битмапом фона

procedure.FormCreate(...);

var

LogBrush: TLogbrush;

begin

FCover := TBitmap.Create;

FCover.LoadFromResourceName(hinstance, 'BMPCOVER');

with LogBrush do

begin

lbStyle := BS_PATTERN;

lbHatch := FCover.Handle;

end;

FHBrush := CreateBrushIndirect(Logbrush);

end;

procedure.FormDestroy(...);

begin

DeleteObject(FHBrush);

FCover.Free;

end;

procedure.CreateWnd;

begin

inherited CreateWnd;

if (ClientHandle <> 0) then

begin

if NewStyleControls then

SetWindowLong(ClientHandle, GWL_EXSTYLE, WS_EX_CLIENTEDGE or

GetWindowLong(ClientHandle, GWL_EXSTYLE));

FNewClientInstance := MakeObjectInstance(NewClientWndProc);

FOldClientInstance := pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));

SetWindowLong(ClientHandle, GWL_WNDPROC, longint(FNewClientInstance));

end;

procedure.NewClientWndProc(var Message: TMessage);

procedure Default;

begin

with Message do

Result := CallWindowProc(FOldClientInstance, ClientHandle, Msg,

wParam,

lParam);

end;

begin

with Message do

begin

case Msg of

WM_ERASEBKGND:

begin

FillRect(TWMEraseBkGnd(Message).DC, ClientRect, FHBrush);

Result := 1;

end;

else

Default;

end;