How do i walpaper a MDI form with icons/bitmaps in Delphi

I'm using Delphi and want to wallpaper the background of my main MDI form with an icon or bitmap.

How is it done?
MARTIN030397Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

sperlingCommented:
Do you want it centered, tiled or stretched?


0
MARTIN030397Author Commented:
Edited text of question
0
LucHoltkampCommented:
Just the same as you would draw a bitmap on a client.
Make a DeviceContext in the Client-window setuproutine and place it on the screen (Using a Compatible DC to select the bitmap in an BitBlt it to the screen. )
0
Cloud Class® Course: MCSA MCSE Windows Server 2012

This course teaches how to install and configure Windows Server 2012 R2.  It is the first step on your path to becoming a Microsoft Certified Solutions Expert (MCSE).

MARTIN030397Author Commented:
I'm sorry, perhaps i should have told you i am just a beginner at delphi, what does your jargon meen in terms of programming?

Device context in client window using compatable DC?

BitBlk is presumably bit block transfer which i have herd of but, i  still do not understand, could you be a bit more specific and slow please.

Martin
0
alona041797Commented:
There is a freeware component which does that.
Save this as MDIBck.pas. In the OnPaint event you can draw your tiled background by calling Draw for the Canvas

---- CUT HERE ----
unit MDIBck;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TMDIPaint = procedure(Sender: TObject; ACanvas: TCanvas; var AClientRect: TRect) of object;

  TMDIBackground = class(TGraphicControl)
  private
    FMDICanvas: TCanvas;
    FBevelWidth: Integer;
    FMDIBackgroundPaint: TMDIPaint;
    FBackgroundColor: TColor;
    FOldClientProc: TFarProc;
    FNewClientProc: TFarProc;
    procedure ClientWndProc(var Mesg: TMessage);
    procedure SetBackgroundColor(const ANewColor: TColor);
    procedure SetBevelWidth(BW: Integer);
  protected
    procedure Paint; override;
    procedure DrawBackground(DC: HDC); dynamic;
    procedure FillClientRect(ACanvas: TCanvas; const ARect: TRect); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BevelWidth: Integer read FBevelWidth write SetBevelWidth default 2;
    property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor default clInactiveCaption;
    property OnPaint: TMDIPaint read FMDIBackgroundPaint write FMDIBackgroundPaint;
  end;

procedure Register;

implementation

uses ExtCtrls;

constructor TMDIBackground.Create(AOwner: TComponent);
begin
   // Create then background only if it's on a Form wich is MDI parent
   if (AOwner is TForm) and (TForm(AOwner).FormStyle = fsMDIForm) then begin
      inherited Create(AOwner);
      Width := 150;
      Height := 40;
      Align := alClient;
      FBackgroundColor := clInactiveCaption;
      FBevelWidth := 2;
      FMDICanvas := TCanvas.Create;

      if not (csDesigning in ComponentState) then begin
         TForm(Owner).HandleNeeded;
         FNewClientProc := MakeObjectInstance(ClientWndProc);
         FOldClientProc := Pointer(GetWindowLong(TForm(Owner).ClientHandle, GWL_WNDPROC));
         SetWindowLong(TForm(Owner).ClientHandle, GWL_WNDPROC, Longint(FNewClientProc));
      end; end
   else begin
      raise Exception.Create('TMDIBackground can only be used on a form '#10 +
                             'with FormStyle = fsMDIForm');
   end;
end;

destructor TMDIBackground.Destroy;
begin
   FMDICanvas.Free;
   if Assigned(FNewClientProc) then begin
      FreeObjectInstance(FNewClientProc);
      SetWindowLong(TForm(Owner).ClientHandle, GWL_WNDPROC, Longint(FOldClientProc));
   end;
   inherited Destroy;
end;

procedure TMDIBackground.ClientWndProc(var Mesg: TMessage);
begin
   with Mesg do begin
      case Msg of
         WM_ERASEBKGND: begin
            CallWindowProc(FOldClientProc, TForm(Owner).ClientHandle, Msg, wParam, lParam);
            DrawBackground(TWMEraseBkGnd(Mesg).DC);
            end;
         WM_VSCROLL, WM_HSCROLL: begin
            Result := CallWindowProc(FOldClientProc, TForm(Owner).ClientHandle, Msg, wParam, lParam);
            InvalidateRect(TForm(Owner).ClientHandle, nil, True);
            end;
         WM_WINDOWPOSCHANGING: begin
            with TWMWindowPosChanging(Mesg) do begin
               Inc(WindowPos^.x, FBevelWidth);
               Inc(WindowPos^.y, FBevelWidth);
               Dec(WindowPos^.cx, 2*FBevelWidth);
               Dec(WindowPos^.cy, 2*FBevelWidth);
            end;
            end;
      else
         Result := CallWindowProc(FOldClientProc, TForm(Owner).ClientHandle, Msg, wParam, lParam);
      end;
   end;
end;

procedure TMDIBackground.SetBackgroundColor(const ANewColor: TColor);
begin
   if (ANewColor <> FBackgroundColor) then begin
      FBackgroundColor := ANewColor;
      if not (csDesigning in ComponentState) then InvalidateRect(TForm(Owner).ClientHandle, nil, True);
      Repaint;
   end;
end;

procedure TMDIBackground.SetBevelWidth(BW: Integer);
var
   iDiff: Integer;
begin
   if (BW <> FBevelWidth) then begin
      iDiff := BW - FBevelWidth;
      FBevelWidth := BW;
      if not (csDesigning in ComponentState) then begin
         SetWindowPos(TForm(Owner).ClientHandle, 0, 0, 0, TForm(Owner).ClientWidth,
                      TForm(Owner).ClientHeight, SWP_NOZORDER + SWP_NOACTIVATE);
      end;
      Repaint;
   end;
end;


procedure TMDIBackground.Paint;
var
   Rect: TRect;
begin
   Rect := GetClientRect;
   if (csDesigning in ComponentState) then begin
      FillClientRect(Canvas, Rect);
   end;
   Frame3D(Canvas, Rect, clBlack, clBtnHighlight, FBevelWidth);
end;

procedure TMDIBackground.DrawBackground(DC: HDC);
var
   Rect: TRect;
begin
   FMDICanvas.Handle := DC;
   Windows.GetClientRect(TForm(Owner).ClientHandle, Rect);
   FillClientRect(FMDICanvas, Rect);
   if Assigned(FMDIBackgroundPaint) then FMDIBackgroundPaint(Self, FMDICanvas, Rect);
end;

procedure TMDIBackground.FillClientRect(ACanvas: TCanvas; const ARect: TRect);
begin
   with ACanvas do begin
      Brush.Style := bsSolid;
      Brush.Color := FBackgroundColor;
      FillRect(ARect);
   end;
end;

procedure Register;
begin
  RegisterComponents('Suppliment', [TMDIBackground]);
end;

end.


0
MARTIN030397Author Commented:
Perhaps i am not using the component correctly but, i have written in the components OnPaint event

 Canvas.Draw(X, Y, Bitmap);

both for MDIBackground1.Canvas.Draw(... which gives an error becouse MDIBackground does not seem to have a canvas property available to me.
and also
Form1.Canvas.Draw(...) does not seem to have any effect either, (or indeed placing a picture on the MDIBackground1)

by the way there was an end; missing out somwhere around the Case statment.

Martin.
0
erajojCommented:
Something like this:

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); { create wrapper }
 MDIDefProc:=pointer(SetWindowLong(ClientHandle,GWL_WNDPROC,
     longint(MDIInstance)) );
end;

procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose:
Boolean);
begin
 { restore default window proc }
 SetWindowLong(ClientHandle,GWL_WNDPROC,longint(MDIDefProc));
 { dispose of instance }
 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 bitmap }
 if FormStyle=fsNormal then
  begin
   wrkY:=0;
   while wrkY < ClientHeight do    { go from top to bottom.. }
    begin
     wrkX:=0;
     while wrkX < ClientWidth do   { ..and left to right. }
      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
 { gradient routine }
 wrkDelta:=255 div (1+ClientHeight); { number of shades desired }
 if wrkDelta=0 then wrkDelta:=1;     { yes, usually 1 }
 wrkSize:=ClientHeight div 240;      { size of blended bars }
 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.

SWP

/// John

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Development

From novice to tech pro — start learning today.