unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls;
type
{ TMyPicturePanel }
TMyPicturePanel = class(TCustomControl)
private
fBorderWidth : Integer;
fBorderColor : TColor;
fStretch : Boolean;
fPicture : TPicture;
procedure SetBorderWidth(AValue : Integer);
function GetBorderWidth : Integer;
procedure SetBorderColor(AValue : TColor);
function GetBorderColor : TColor;
procedure SetStretch(AValue : Boolean);
function GetStretch : Boolean;
procedure SetPicture(AValue : TPicture);
function GetPicture : TPicture;
public
MyImage : TImage;
MyPanel : TPanel;
constructor Create(AOwner : TComponent; theParent: TForm);
published
procedure MyPaint(Sender: TObject);
property BorderWidth : Integer read GetBorderWidth write SetBorderWidth;
property BorderColor : TColor read GetBorderColor write SetBorderColor;
property Stretch : Boolean read GetStretch write SetStretch;
property Picture : TPicture read GetPicture write SetPicture;
end;
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
FPicturePanel: TMyPicturePanel;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
APicture: TPicture;
begin
FPicturePanel := TMyPicturePanel.Create(Self, Self);
APicture := TPicture.Create;
APicture.LoadFromFile('project1.ico');
FPicturePanel.SetPicture(APicture);
APicture.Free;
end;
{ TMyPicturePanel }
constructor TMyPicturePanel.Create(AOwner: TComponent; theParent: TForm);
begin
inherited Create(AOwner);
fBorderColor := clBlack;
fBorderWidth := 1;
fStretch := False;
fPicture := TPicture.Create;
MyPanel := TPanel.Create(Self);
with MyPanel do
begin;
Parent := theParent;
Align := alClient;
BorderStyle := bsNone;
BevelInner := bvNone;
BevelOuter := bvNone;
Color := clLime;
OnPaint := @MyPaint;
end;
MyImage := TImage.Create(Self);
with MyImage do
begin
Align := alClient;
BorderSpacing.Around := 8;
Parent := MyPanel;
Stretch := fStretch;
Picture := fPicture;
end;
Constraints.MinHeight := 10;
Constraints.MinWidth := 10;
SetBounds(0, 0, 96, 96);
end;
procedure TMyPicturePanel.SetBorderWidth(AValue : Integer);
begin
if fBorderWidth <> AValue then
begin
fBorderWidth := AValue;
MyPaint(MyPanel);
MyImage.Repaint;
end;
end;
function TMyPicturePanel.GetBorderWidth : Integer;
begin
Result := fBorderWidth;
end;
procedure TMyPicturePanel.SetBorderColor(AValue : TColor);
begin
if fBorderColor <> AValue then
begin
fBorderColor := AValue;
MyPaint(MyPanel);
MyImage.Repaint;
end;
end;
function TMyPicturePanel.GetBorderColor : TColor;
begin
Result := fBorderColor;
end;
procedure TMyPicturePanel.SetStretch(AValue : Boolean);
begin
if fStretch <> AValue then
begin
fStretch := AValue;
MyImage.Stretch := fStretch;
MyImage.Repaint;
end;
end;
function TMyPicturePanel.GetStretch : Boolean;
begin
Result := fStretch;
end;
procedure TMyPicturePanel.SetPicture(AValue : TPicture);
begin
if fPicture <> AValue then
begin
fPicture.Assign(AValue);
// MyPaint(MyPanel);
Invalidate;
end;
end;
function TMyPicturePanel.GetPicture : TPicture;
begin
Result := fPicture;
end;
procedure TMyPicturePanel.MyPaint(Sender: TObject);
var
iOFFSET : Integer;
begin
iOFFSET := (fBorderWidth - 1) div 2;
MyImage.Picture.Assign(fPicture);
with (Sender as TPanel) do
begin
Canvas.Pen.Color := fBorderColor;
Canvas.Pen.Width := fBorderWidth;
Canvas.Rectangle(iOFFSET, iOFFSET, (Width - iOFFSET), (Height - iOFFSET));
end;
MyImage.BorderSpacing.Around := fBorderWidth + iOFFSET + 1;
end;
end.