Poner una imagen de fondo en una aplicación MDI

5532 vistas

Para conseguir este propósito, vamos a presentar una unit (componente) que realizará esta tarea por nosotros. De lo que se trata es de sustituir el método que controla la zona cliente de la ventana MDI para reemplazarlo por un método de sustitución que permitirá dibujar una imagen a nuestro gusto.

El componente permite poner la imagen en mosaico o estirado.



delphi
  1. unit imMDIBkg;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
  7.  
  8. type
  9.   TPositionImage = (piMosaic, piStretch);
  10.  
  11.   TimMDIBkg = class(TComponent)
  12.   private
  13.     FBitmap: TBitmap;
  14.     FForm: TForm;
  15.     FPosImage: TPositionImage;
  16.     procedure SetBitmap(Value: TBitmap);
  17.     procedure InternalClientProc(var M: TMessage);
  18.     procedure SetPosImage(const Value: TPositionImage);
  19.   protected
  20.     FClientInstance: TFarProc;
  21.     FPrevClientProc: TFarProc;
  22.     property Form: TForm read FForm;
  23.   public
  24.     constructor Create(AOwner: TComponent); override;
  25.     destructor Destroy; override;
  26.   published
  27.     property Bitmap: TBitmap read FBitmap write SetBitmap;
  28.     property PosImage: TPositionImage read FPosImage write SetPosImage;
  29.   end;
  30.  
  31. implementation
  32.  
  33. { TimMDIBkg }
  34.  
  35. constructor TimMDIBkg.Create(AOwner: TComponent);
  36. begin
  37.   inherited Create(AOwner);
  38.  
  39.   FForm := AOwner as TForm;
  40.   FBitmap := TBitmap.Create;
  41.   FPosImage := piMosaic;
  42.  
  43.   FClientInstance := MakeObjectInstance(InternalClientProc);
  44.   FPrevClientProc := Pointer( SetWindowLong(Form.ClientHandle, GWL_WNDPROC, Integer(FClientInstance)) );
  45. end;
  46.  
  47. destructor TimMDIBkg.Destroy;
  48. begin
  49.   SetWindowLong(Form.ClientHandle, GWL_WNDPROC, Integer(FPrevClientProc));
  50.   FreeObjectInstance(FClientInstance);
  51.   FBitmap.Free;
  52.   inherited Destroy;
  53. end;
  54.  
  55. procedure TimMDIBkg.InternalClientProc(var M: TMessage);
  56. var
  57.   SrcDC, DstDC: hDC;
  58.   R, C, H, W: Word;
  59. begin
  60.   if not FBitmap.Empty then
  61.     case M.Msg of
  62.       WM_HSCROLL, WM_VSCROLL:
  63.         InvalidateRect(Form.ClientHandle, nil, False);
  64.       WM_ERASEBKGND:
  65.         begin
  66.           SrcDc := Bitmap.Canvas.Handle;
  67.           DstDc := TWMEraseBkGnd(M).DC;
  68.           H := Bitmap.Height;
  69.           W := Bitmap.Width;
  70.           case FPosImage of
  71.             piMosaic:
  72.               for R := 0 to Form.ClientHeight div H do
  73.                 for C := 0 to Form.ClientWidth div W do
  74.                   BitBlt(DstDC, C * W, R * H, W, H, SrcDC, 0, 0, SRCCOPY);
  75.             piStretch:
  76.               StretchBlt(DstDC, 0, 0, Form.ClientWidth, Form.ClientHeight, SrcDC, 0, 0, W, H, SRCCOPY);
  77.           end;
  78.           M.Result := 1;
  79.           Exit;
  80.         end;
  81.     end;
  82.   M.Result := CallWindowProc(FPrevClientProc, Form.ClientHandle,
  83.     M.Msg, M.wParam, M.lParam);
  84. end;
  85.  
  86. procedure TimMDIBkg.SetBitmap(Value: TBitmap);
  87. begin
  88.   FBitmap.Assign(Value);
  89.   FForm.Invalidate;
  90. end;
  91.  
  92. procedure TimMDIBkg.SetPosImage(const Value: TPositionImage);
  93. begin
  94.   FPosImage := Value;
  95.   FForm.Invalidate;
  96. end;
  97.  
  98. end.



Y su forma de uso sencilla:



delphi
  1. unit Unit1;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7.   Dialogs, imMDIBkg;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.   private
  12.     imMDIBkg1: TimMDIBkg;
  13.   public
  14.     constructor Create(aOwner: TComponent); override;
  15.   end;
  16.  
  17. var
  18.   Form1: TForm1;
  19.  
  20. implementation
  21.  
  22. {$R *.dfm}
  23.  
  24. { TForm1 }
  25.  
  26. constructor TForm1.Create(aOwner: TComponent);
  27. begin
  28.   inherited;
  29.  
  30.   imMDIBkg1 := TimMDIBkg.Create(Self);
  31.   imMDIBkg1.Bitmap.LoadFromFile('c:\miImagen.bmp');
  32.   imMDIBkg1.PosImage := piStretch;
  33. end;
  34.  
  35. end.