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.

FClientInstance: TFarProc;

FPrevClientProc: TFarProc;

procedure ClientWndProc(var message: TMessage);

procedure TMainForm.ClientWndProc(var message: TMessage);

var

 Dc: hDC;

 Row: Integer;

 Col: Integer;

begin

 with message do

  case Msg of

  WM_ERASEBKGND:

  begin

  Dc := TWMEraseBkGnd(message).Dc;

  for Row := 0 to ClientHeight div Image1.Picture.Height do

  for Col := 0 to ClientWidth div Image1.Picture.Width do

  BitBlt(Dc, Col * Image1.Picture.Width, Row *

  Image1.Picture.Height, Image1.Picture.Width,

  Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle,

  0, 0, SRCCOPY);

  Result := 1;

  end;

  else

  Result := CallWindowProc(FPrevClientProc,

  ClientHandle, Msg, wParam, lParam);

  end;

end;

FClientInstance := MakeObjectInstance(ClientWndProc);

FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));

SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));

procedure TForm.OnPaint(Sender: TObject);
 procedure Tile(c: TCanvas; b: TBitMap);
 var
  x, y, h, w, i, j: integer;
 begin
  with b do
  begin
  h := b.height;
  w := b.width;
  end;
  y := 0;
  with c.Cliprect do
  begin
  i := bottom - top - 1; //высота
  j := right - left - 1; //ширина
  end;
  while y < i do
  begin
  x := 0;
  while x < j do
  begin
  c.draw(x, y, b);
  inc(x, w);
  end;
  inc(y, h);
  end;
 end;
begin
 if Sender is TForm then
  Tile(TForm(Sender).Canvas, fTileWith);
end;

...

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 - ) div bmW);

  end;

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

  GetWindowRect(F.Handle, WndR);

  with ScreenToClient(WndR.Left) 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;

  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;

...

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;

 end;

end;

procedure TMainForm.FormDestroy(Sender: TObject);

begin

 OutCanvas.Free;

end;

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