Советы по Delphi

         

Фон MDI-окон


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

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

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

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 dobeginif Msg=WM_ERASEBKGND thenbeginif mnuBitmap.Checked thenShowBitmap(wParam)elseShowGradient(wParam,255,0,0);Result:=1;endelseResult:=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);
varwrkDC:hDC;begin
wrkDC:=GetDC(ClientHandle);ShowBitmap(wrkDC);ReleaseDC(ClientHandle,wrkDC);mnuBitmap.Checked:=true;mnuGradient.Checked:=false;end;

procedure TfrmMain.mnuGradientClick(Sender: TObject);
varwrkDC: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);
varwrkSource:TRect;wrkTarget:TRect;wrkX:integer;wrkY:integer;begin
{ заполняем (tile) окно изображением }if FormStyle=fsNormal thenbeginwrkY:=0;while wrkY < ClientHeight do { заполняем сверху вниз.. }beginwrkX:=0;while wrkX < ClientWidth do { ..и слева направо. }beginCanvas.Draw(wrkX,wrkY,imgTile.Picture.Bitmap);Inc(wrkX,glbImgWidth);end;Inc(wrkY,glbImgHeight);end;endelse if FormStyle=fsMDIForm thenbeginWindows.GetClientRect(ClientHandle,wrkTarget);wrkY:=0;while wrkY < wrkTarget.Bottom dobeginwrkX:=0;while wrkX < wrkTarget.Right dobeginBitBlt(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);
varwrkBrushNew: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) dobeginwrkColor:=RGB(prmRed,prmGreen,prmBlue);wrkRect:=Rect(0,wrkY*wrkSize,ClientWidth,(wrkY+1)*wrkSize);if FormStyle=fsNormal thenbeginCanvas.Brush.Color:=wrkColor;Canvas.FillRect(wrkRect);endelse if FormStyle=fsMDIForm thenbeginwrkBrushNew:=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 thenif mnuBitMap.Checked thenmnuBitMapClick(Sender)elsemnuGradientClick(Sender);end;

end.

[000170]



Содержание раздела