Mega Code Archive
A background painter class
<![CDATA[
Title: A background painter class
Question: Have you ever wanted to paint a bitmap tiled? centered? stretched? use this class
Answer:
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 begin
YPos := ARect.Top;
while YPos 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.
]]>