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