Solved

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

Posted on 1997-03-06
7
781 Views
Last Modified: 2013-12-03
I'm using Delphi and want to wallpaper the background of my main MDI form with an icon or bitmap.

How is it done?
0
Comment
Question by:MARTIN030397
7 Comments
 
LVL 3

Expert Comment

by:sperling
ID: 1334162
Do you want it centered, tiled or stretched?


0
 

Author Comment

by:MARTIN030397
ID: 1334163
Edited text of question
0
 
LVL 3

Expert Comment

by:LucHoltkamp
ID: 1334164
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
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 

Author Comment

by:MARTIN030397
ID: 1334165
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
 
LVL 2

Expert Comment

by:alona041797
ID: 1334166
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
 

Author Comment

by:MARTIN030397
ID: 1334167
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
 
LVL 4

Accepted Solution

by:
erajoj earned 50 total points
ID: 1334168
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

Featured Post

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

If you have ever found yourself doing a repetitive action with the mouse and keyboard, and if you have even a little programming experience, there is a good chance that you can use a text editor to whip together a sort of macro to automate the proce…
For a while now I'v been searching for a circular progress control, much like the one you get when first starting your Silverlight application. I found a couple that were written in WPF and there were a few written in Silverlight, but all appeared o…
This is Part 3 in a 3-part series on Experts Exchange to discuss error handling in VBA code written for Excel. Part 1 of this series discussed basic error handling code using VBA. http://www.experts-exchange.com/videos/1478/Excel-Error-Handlin…
In this seventh video of the Xpdf series, we discuss and demonstrate the PDFfonts utility, which lists all the fonts used in a PDF file. It does this via a command line interface, making it suitable for use in programs, scripts, batch files — any pl…

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now