[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    {
    DCR module located at the bottom !!

    How To Use:

    In the OnCreate - event of the form, put something like this:

    begin
      Tiler1.Attach;
    end;

    and everything will work out fine...
    }

    unit uTiler;
    //----------------------------------------------------------------------------//
    // TTiler V1.0                                                                //
    // By Martijn Tonies / Upscene Productions Holland                            //
    // Copyright 1997 by Upscene Productions                                      //
    // This code may be used, but may not be modified for commercial use.         //
    //----------------------------------------------------------------------------//

    interface

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

    type
      TTileMode = (tmTile, tmStretch, tmCenter);
      TTiler = class(TComponent)
      private
        Attached: Boolean;
        FActive: Boolean;
        FBitmap: TBitmap;
        FTileMode: TTileMode;

        FHandle: HWND;

        FClientInstance: TFarProc;
        FDefClientProc: TFarProc;

        procedure SetActive(Value: Boolean);
        procedure SetBitmap(Value: TBitmap);
        procedure SetTileMode(Value: TTileMode);

        procedure ClientWndProc(var Message: TMessage);
        procedure FillClientArea(DC: HDC);
        procedure Stretch(DC: HDC);
        procedure Tile(DC: HDC);
        procedure Center(DC: HDC);
        { Private declarations }
      protected
        constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;
        { Protected declarations }
      public
        procedure Attach;
        { Public declarations }
      published
        property Active: Boolean read FActive write SetActive stored True;
        property Bitmap: TBitmap read FBitmap write SetBitmap stored True;
        property TileMode: TTileMode read FTileMode write SetTileMode stored True;
        { Published declarations }
      end;

    procedure Register;

    implementation

    procedure TTiler.Attach;
    begin
      if FBitmap.Handle = 0
      then begin
             raise Exception.Create('TTiler can''t be attached unless you assign a bitmap to it!');
           end
      else begin
             if (Owner as TForm).FormStyle = fsMDIForm
             then FHandle := (Owner as TForm).ClientHandle
             else FHandle := (Owner as TForm).Handle;
             FClientInstance := MakeObjectInstance(ClientWndProc);
             FDefClientProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
             SetWindowLong(FHandle, GWL_WNDPROC, LongInt(FClientInstance));
             Attached := True;
           end;
    end;

    constructor TTiler.Create(AOwner: TComponent);
    begin
      inherited Create(AOwner);
      FActive := True;
      FBitmap := TBitmap.Create;
      Attached := False;
    end;

    destructor TTiler.Destroy;
    begin
      FBitmap.Free;
      inherited Destroy;
    end;

    procedure TTiler.ClientWndProc(var Message: TMessage);
      procedure Default;
      begin
        with Message
        do Result := CallWindowProc(FDefClientProc, FHandle, Msg, wParam, lParam);
      end;
    begin
      with Message
      do begin
           case Msg of
             WM_NCHITTEST          : begin
                                       Default;
                                       if Result = HTCLIENT
                                       then Result := HTTRANSPARENT;
                                     end;
             WM_ERASEBKGND         : begin
                                       if Assigned(FBitmap) and Active
                                       then FillClientArea(TWMEraseBkgnd(Message).DC)
                                       else FillRect(TWMEraseBkgnd(Message).DC, (Owner as TForm).ClientRect, (Owner as TForm).Brush.Handle);
                                       Result := 1;
                                     end;
           else Default;
           end;
         end;
    end;

    procedure TTiler.FillClientArea(DC: HDC);
    begin
      case FTileMode of
        tmStretch   : Stretch(DC);
        tmTile      : Tile(DC);
        tmCenter    : Center(DC);
      end;
    end;

    procedure TTiler.Center(DC: HDC);
    var Form: TForm;
        R: TRect;
        x, y: LongInt;
        w, h: LongInt;
    begin
      Form := Owner as TForm;
      R := Form.ClientRect;
      x := (R.Right div 2) - (FBitmap.Width div 2);
      y := (R.Bottom div 2) - (FBitmap.Height div 2);
      w := x + FBitmap.Width;
      h := y + FBitmap.Height;
      FillRect(DC, R, Form.Brush.Handle);
      BitBlt(DC, x, y, w, h, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);

      ReleaseDC(FHandle, DC);
    end;

    procedure TTiler.Stretch(DC: HDC);
    var Form: TForm;
        R: TRect;
    begin
      Form := Owner as TForm;
      R := Form.ClientRect;
      StretchBlt(DC, R.Left, R.Top, R.Right, R.Bottom, FBitmap.Canvas.Handle, 0, 0, FBitmap.Width, FBitmap.Height, SRCCOPY);
      ReleaseDC(FHandle, DC);
    end;

    procedure TTiler.Tile(DC: HDC);
    var x, y, bmWidth, bmHeight: Integer;
        bmHandle: Integer;
    begin
      x := 0;
      bmWidth := FBitmap.Width;
      bmHeight := FBitmap.Height;
      bmHandle := FBitmap.Canvas.Handle;

      while x < (Owner as TForm).Width
      do begin
           y := 0;
           while y < (Owner as TForm).Height
           do begin
                BitBlt(DC, x, y, x + bmWidth, y + bmHeight,
                       bmHandle, 0, 0, SRCCOPY);
                BitBlt(DC, x, y + bmHeight, x + bmWidth, y + bmHeight,
                       bmHandle, 0, 0, SRCCOPY);
                BitBlt(DC, x + bmWidth, y, x + bmWidth, y + bmHeight,
                       bmHandle, 0, 0, SRCCOPY);
                BitBlt(DC, x + bmWidth, y + bmHeight, x + bmWidth, y + bmHeight,
                       bmHandle, 0, 0, SRCCOPY);
                y := y + bmHeight * 2;
              end;
           x := x + bmWidth * 2;
         end;
      ReleaseDC(FHandle, DC);
    end;

    procedure TTiler.SetActive(Value: Boolean);
    begin
      if Value <> FActive
      then if (not Attached) and Value
           then raise Exception.Create('TTiler can''t be active unless you assign a bitmap to it!')
           else begin
                  FActive := Value;
                  if not (csDesigning in ComponentState)
                  then if not FActive and Attached
                       then FillRect(GetDC(FHandle), (Owner as TForm).ClientRect, (Owner as TForm).Brush.Handle)
                       else if Attached and FActive
                            then FillClientArea(GetDC(FHandle));
                end;
    end;

    procedure TTiler.SetBitmap(Value: TBitmap);
    begin
      FBitmap.Assign(Value);
    end;

    procedure TTiler.SetTileMode(Value: TTileMode);
    begin
      if Value <> FTileMode
      then begin
             FTileMode := Value;
           end;
    end;

    procedure Register;
    begin
      RegisterComponents('Upscene', [TTiler]);
    end;

    end.
    { the following contains additional files that should be included with this
      file.  To extract, you need XX3402 available with the SWAG distribution.

      1.     Cut the text below out, and save to a file  ..  filename.xx
      2.     Use XX3402  :   xx3402 d filename.xx
      3.     The decoded file should be created in the same directory.
      4.     If the file is a archive file, use the proper archive program to
             extract the members.

    { ------------------            CUT              ----------------------}

    *XX3402-000468-301297--72--85-63287------UTILER.DCR--1-OF--1
    +++++0++++1zzk++zzw+++++++++++++++++++++++06+E++9++++Dzz+U-I+3E+GE-A+2I+
    IU+++++++++++-+E2kE++++++++++0U++++M++++4+++++2+-+++++++6+2+++++++++++++
    ++++++++++++++++++0+++0+++++U6++U++++6++U+0+U+++U60++A1+k++++Dw++Dw+++1z
    zk1z++++zk1z+Dzz++1zzzw+AnAnAnAnAnAnAnAnAnAnAnAnAnAnAnAnA1AnAnAnAnAnAnAn
    A+AnAnAnAnAnAnAnA6+nAnAnAnAnAnAnA++++1AnAnAnAnAnA6W+W+AnAnAnAnAnA6W+W6+n
    AnAnAnAnA6W+W6+nAnAnAnAnA++++++1AnAnAnAnA6W+W6+1AnAnAnAnA6W+W60++nAnAnAn
    A6W+W606U++nAnAnA++++++++++1AnAnA6W+W606U6U1AnAnA6W+W606U6W+AnAnA6W+W606
    U6W+AnAnA+++++++++++AnAnA6W+W606U6W++nAnA6W+W606U6W+U1AnA6W+W606U6W+W+An
    A++++++++++++++nAnAnAnAnAnAnAnAnAnAnAnAnAnAnAnAn
    ***** END OF BLOCK 1 *****

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]