Have you ever wanted to paint a bitmap tiled? centered? stretched? use this class

Here is a class I found long ago from one of those lost to memory sources, its sole purpose is to paint the background of a window using a given picture (you can extend its use by using tgraphic descendants such as tjpegpicture, add JPeg in the uses clause; TGifImage, add Anders Melanders gif; etc.)

unit bgpaint;

interface

uses
  Windows, Graphics, Classes;

type
  TTileBackStyle = (tbsNone, tbsPicCenter, tbsPicClip, tbsPicFit, tbsPicHeigth,
    tbsPicStretch, tbsPicTile, tbsPicWidth);

  TTileBack = class( TPersistent )
  private
    FPicture: TPicture;
    FStyle: TTileBackStyle;
    FOnChange: TNotifyEvent;

    procedure SetStyle(const Value: TTileBackStyle);
    procedure SetOnChange(const Value: TNotifyEvent);
    procedure SetPicture(const Value: TPicture);
  public
    constructor Create;
    destructor  Destroy; override;
    procedure Assign(Source: TPersistent); override;

    function Empty: Boolean;
    procedure Draw(const Canvas: TCanvas; const ARect: TRect);
    property OnChange: TNotifyEvent read FOnChange write SetOnChange;
  published
    property Picture: TPicture read FPicture write SetPicture;
    property Style: TTileBackStyle read FStyle write SetStyle default tbsNone;
  end;

implementation

{ TTileBack }

procedure TTileBack.Assign(Source: TPersistent);
begin
  if Source is TTileBack then
    with TTileBack(Source) do
    begin
      Self.FStyle := Style;
      Self.Picture:= Picture;
    end
  else
    inherited
end;

constructor TTileBack.Create;
begin
  FPicture := TPicture.Create;
  FStyle := tbsNone;
end;

destructor TTileBack.Destroy;
begin
  FPicture.Free;
  inherited Destroy;
end;

procedure TTileBack.Draw(const Canvas: TCanvas; const ARect: TRect);
var
  Dest: TRect;
  XPos, YPos, RWidth, RHeight: Integer;
  PicRatio, ImageRatio: Double;
begin
  if Empty then Exit;

  RWidth := ARect.Right - ARect.Left;
  RHeight:= ARect.Bottom- ARect.Top;
  XPos := 0;
  YPos := 0;

  case Style of
    tbsNone: Exit;

    tbsPicClip:
      Canvas.Draw(ARect.Left, ARect.Top, Picture.Graphic);

    tbsPicCenter:
    begin
      XPos := ARect.Left + (RWidth - Picture.Width) div 2;
      YPos := ARect.Top  + (RHeight- Picture.Height)div 2;
      Canvas.Draw(XPos, YPos, Picture.Graphic);
    end;

    tbsPicFit:
    begin
      if (FPicture.Width > 0) and (FPicture.Height > 0) then
      begin
        PicRatio := Picture.Height / Picture.Width;
        ImageRatio:=RHeight / RWidth;
        if PicRatio > ImageRatio then
        begin
          XPos := Trunc(RHeight / PicRatio);
          YPos := RHeight;
        end
        else
        begin
          XPos := RWidth;
          YPos := Trunc( RWidth * PicRatio );
        end;
      end;
      Dest := Rect( 0,0,XPos, YPos);
      OffsetRect(Dest, ARect.Left, ARect.Top);
      Canvas.StretchDraw(Dest, Picture.Graphic);
    end;

    tbsPicHeigth:
    begin
      XPos := Trunc(FPicture.Width * (RHeight / Picture.Height));
      YPos := RHeight;
      Dest := Rect(0, 0, XPos, YPos);
      OffsetRect(Dest, ARect.Left, ARect.Top);
      Canvas.StretchDraw(Dest, FPicture.Graphic);
    end;

    tbsPicStretch:
      Canvas.StretchDraw(ARect, Picture.Graphic);

    tbsPicTile:
    begin
      XPos := ARect.Left;
      while XPos < ARect.Right do
      begin
        YPos := ARect.Top;
        while YPos < ARect.Bottom do
        begin
          Canvas.Draw(XPos, Ypos, Picture.Graphic);
          YPos := YPos + FPicture.Height;
        end;
        XPos := XPos + Picture.Width;
      end;
    end;

    tbsPicWidth:
    begin
      XPos := RWidth;
      YPos := Trunc(RWidth * (Picture.Height / Picture.Width));
      Dest := Rect(0,0, XPos, YPos);
      OffsetRect(Dest, ARect.Left, ARect.Top);
      Canvas.StretchDraw(Dest, Picture.Graphic);
    end;
  end;
end;

function TTileBack.Empty: Boolean;
begin
  Result := (Style = tbsNone) or
    ((Style in [tbsPicClip, tbsPicFit, tbsPicHeigth, tbsPicStretch, tbsPicTile, tbsPicWidth]) and
    ((Picture = nil) or (Picture.Graphic = nil) or (Picture.Graphic.Empty)))
end;

procedure TTileBack.SetOnChange(const Value: TNotifyEvent);
begin
  FOnChange := Value;
  FPicture.OnChange := Value;
end;

procedure TTileBack.SetPicture(const Value: TPicture);
begin
  FPicture.Assign( Value );
end;

procedure TTileBack.SetStyle(const Value: TTileBackStyle);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;
    if Assigned(FOnChange) then
      FOnChange(Self);
  end;
end;

end.

Here is a quick and dirty example of its usage and powers:


unit bgpaintex1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, bgPaint, StdCtrls, JPeg;

type
  TForm1 = class(TForm)
    Image1: TImage;
    ComboBox1: TComboBox;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    aBG: TTileBack;
  end;

var
  Form1: TForm1;

implementation

uses TypInfo;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var i: TTileBackStyle;
begin
  aBG := TTileBack.Create;
  aBG.Picture := Image1.Picture;
  aBG.Style := tbsPicFit;
  for i := tbsNone to tbsPicWidth do
  begin
    ComboBox1.Items.AddObject(GetEnumName(TypeInfo(TTileBackStyle), Integer(i)), TObject(i));
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  aBG.Draw(Canvas, ClientRect);
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
  aBG.Style := TTileBackStyle(ComboBox1.Items.Objects[ComboBox1.ItemIndex]);
  Invalidate;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    Image1.Picture.LoadFromFile(OpenDialog1.FileName);
    aBG.Picture := Image1.Picture;
    Invalidate;
  end;
end;

end.