Советы по 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 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.

[000170]



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