Фон MDI-окон

Written on . Posted in [Delphi] Пользовательский интерфейс. Окна и формы

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

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

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;
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;
end;
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;
end;

procedure TfrmMain.FormPaint(Sender: TObject);
begin
if FormStyle=fsNormal then
if mnuBitMap.Checked then
mnuBitMapClick(Sender)
else
mnuGradientClick(Sender);
end;

end.
avr форум