unit TRM_ImageLabel;
(*
TRM_ImageLabel erstellt von Mathias Fiege 2024
www.nogad.de
Open Source License
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software component and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation the
rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
sell copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
Thanks and greetings to www.delphipraxis.net
*)
interface
uses
System.Classes,
Vcl.Controls,
Vcl.ExtCtrls,
Vcl.Forms,
Vcl.Imaging.GIFConsts,
Vcl.Imaging.GIFImg,
Vcl.Imaging.JConsts,
Vcl.Imaging.jpeg,
Vcl.Imaging.pngimage,
Vcl.Imaging.pnglang,
Vcl.StdCtrls,
Vcl.Graphics;
const
_version = '
2024.05.19.0015';
type
TTRM_ImageLabel =
class(TCustomPanel)
private
FSubImage: TImage;
FSubImageAlign: TAlign;
FSubLabel: TLabel;
FSubLabelCaption:
String;
FSubLabelAlign: TAlign;
FPictureDefault: TPicture;
FPictureHover: TPicture;
FPictureLeave: TPicture;
FHoverLeaveLabel: Boolean;
FHoverLeaveImage: Boolean;
FVersion:
String;
function GetSubImageAlign: TAlign;
procedure SetSubImageAlign(Value: TAlign);
function GetPictureDefault: TPicture;
procedure SetPictureDefault(Value: TPicture);
procedure ChangePictureDefault(Sender: TObject);
function GetPictureHover: TPicture;
procedure SetPictureHover(Value: TPicture);
function GetPictureLeave: TPicture;
procedure SetPictureLeave(Value: TPicture);
function GetLabelCaption:
String;
procedure SetLabelCaption(
const Value:
String);
function GetSubLabelAlign: TAlign;
procedure SetSubLabelAlign(Value: TAlign);
procedure ImageClick(Sender: TObject);
procedure ImageDblClick(Sender: TObject);
procedure ImageMouseEnter(Sender: TObject);
procedure ImageMouseLeave(Sender: TObject);
procedure LabelClick(Sender: TObject);
procedure LabelDblClick(Sender: TObject);
procedure LabelMouseEnter(Sender: TObject);
procedure LabelMouseLeave(Sender: TObject);
protected
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
published
property SubImage: TImage
read FSubImage;
property SubLabel: TLabel
read FSubLabel;
property Align;
property Anchors;
property BevelInner;
property BevelKind;
property BevelOuter;
property BevelWidth;
property BorderWidth;
property BorderStyle;
property Caption;
property Ctl3D;
property Cursor;
property ParentBackground;
property PopupMenu;
property OnClick;
property OnDblClick;
property OnMouseEnter;
property OnMouseLeave;
property PictureDefault: TPicture
read GetPictureDefault
write SetPictureDefault;
property PictureHover: TPicture
read GetPictureHover
write SetPictureHover;
property PictureLeave: TPicture
read GetPictureLeave
write SetPictureLeave;
property HoverLeaveLabel: Boolean
read FHoverLeaveLabel
write FHoverLeaveLabel
default True;
property HoverLeaveImage: Boolean
read FHoverLeaveImage
write FHoverLeaveImage
default True;
property ImageAlign: TAlign
read GetSubImageAlign
write SetSubImageAlign
default alClient;
property LabelCaption:
String read GetLabelCaption
write SetLabelCaption;
property LabelAlign: TAlign
read GetSubLabelAlign
write SetSubLabelAlign
default alBottom;
property Version:
String read FVersion;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('
TRM', [TTRM_ImageLabel]);
end;
{ TTRM_ImageLabel }
constructor TTRM_ImageLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Self.Parent := TWinControl(AOwner);
FSubImage := TImage.Create(Self);
FSubImage.SetSubComponent(True);
FSubImage.Parent := Self;
// FSubImage.Align := alClient;
FSubImage.Center := True;
FSubImage.OnClick := ImageClick;
FSubImage.OnDblClick := ImageDblClick;
FSubImage.OnMouseEnter := ImageMouseEnter;
FSubImage.OnMouseLeave := ImageMouseLeave;
FSubLabel := TLabel.Create(Self);
FSubLabel.SetSubComponent(True);
FSubLabel.Parent := Self;
// FSubLabel.Align := alBottom;
FSubLabel.AutoSize := True;
FSubLabel.Height := 25;
FSubLabel.AlignWithMargins := False;
FSubLabel.Margins.Left := 0;
FSubLabel.Margins.Right := 0;
FSubLabel.Margins.Top := 8;
FSubLabel.Margins.Bottom := 0;
FSubLabel.Caption := '
...';
FSubLabel.Font.Size := 14;
FSubLabel.OnClick := LabelClick;
FSubLabel.OnDblClick := LabelDblClick;
FSubLabel.OnMouseEnter := LabelMouseEnter;
FSubLabel.OnMouseLeave := LabelMouseLeave;
FPictureDefault := TPicture.Create;
FPictureDefault.OnChange := ChangePictureDefault;
FPictureHover := TPicture.Create;
FPictureLeave := TPicture.Create;
Self.Width := 64;
Self.Height := 89;
Self.AlignWithMargins := True;
Self.Margins.Top := 0;
Self.Margins.Left := 8;
Self.Margins.Right := 8;
Self.Margins.Bottom := 0;
Self.BevelInner := bvNone;
Self.BevelKind := bkNone;
Self.BevelOuter := bvNone;
Self.BevelWidth := 1;
Self.BorderStyle := bsNone;
Self.BorderWidth := 0;
Self.Caption := '
';
Self.Ctl3D := False;
Self.Cursor := crHandPoint;
Self.ParentBackground := True;
HoverLeaveLabel := True;
HoverLeaveImage := True;
ImageAlign := alClient;
LabelAlign := alBottom;
FVersion := _version;
end;
function TTRM_ImageLabel.GetSubImageAlign: TAlign;
begin
Result := FSubImageAlign;
FSubImage.Align := FSubImageAlign;
Repaint;
end;
procedure TTRM_ImageLabel.SetSubImageAlign(Value: TAlign);
begin
if FSubImageAlign <> Value
then
begin
FSubImageAlign := Value;
FSubImage.Align := FSubImageAlign;
Repaint;
end;
end;
function TTRM_ImageLabel.GetPictureDefault: TPicture;
begin
Result := FPictureDefault;
FSubImage.Picture.Assign(FPictureDefault);
Repaint;
end;
procedure TTRM_ImageLabel.SetPictureDefault(Value: TPicture);
begin
if FPictureDefault <> Value
then
begin
FPictureDefault.Assign(Value);
FSubImage.Picture.Assign(FPictureDefault);
Repaint;
end;
end;
procedure TTRM_ImageLabel.ChangePictureDefault(Sender: TObject);
begin
FSubImage.Picture.Assign(FPictureDefault);
Repaint;
end;
function TTRM_ImageLabel.GetPictureHover: TPicture;
begin
Result := FPictureHover;
end;
procedure TTRM_ImageLabel.SetPictureHover(Value: TPicture);
begin
if FPictureHover <> Value
then
FPictureHover.Assign(Value);
end;
function TTRM_ImageLabel.GetPictureLeave: TPicture;
begin
Result := FPictureLeave;
end;
procedure TTRM_ImageLabel.SetPictureLeave(Value: TPicture);
begin
if FPictureLeave <> Value
then
FPictureLeave.Assign(Value);
end;
function TTRM_ImageLabel.GetLabelCaption:
String;
begin
if FSubLabelCaption = '
'
then
Result := SubLabel.Caption
else
Result := FSubLabelCaption;
Repaint;
end;
procedure TTRM_ImageLabel.SetLabelCaption(
const Value:
string);
begin
if FSubLabelCaption <> Value
then
begin
FSubLabelCaption := Value;
Self.SubLabel.Caption := FSubLabelCaption;
Repaint;
end;
end;
function TTRM_ImageLabel.GetSubLabelAlign: TAlign;
begin
Result := FSubLabelAlign;
FSubLabel.Align := FSubLabelAlign;
Repaint;
end;
procedure TTRM_ImageLabel.SetSubLabelAlign(Value: TAlign);
begin
if FSubLabelAlign <> Value
then
begin
FSubLabelAlign := Value;
FSubLabel.Align := FSubLabelAlign;
Repaint;
end;
end;
procedure TTRM_ImageLabel.ImageClick(Sender: TObject);
begin
if assigned(OnClick)
then
inherited OnClick(Self);
end;
procedure TTRM_ImageLabel.ImageDblClick(Sender: TObject);
begin
if assigned(OnDblClick)
then
inherited OnDblClick(Self);
end;
procedure TTRM_ImageLabel.ImageMouseEnter(Sender: TObject);
begin
if HoverLeaveImage
then
begin
Self.SubImage.Picture.Assign(FPictureHover);
Repaint;
end;
if assigned(OnMouseEnter)
then
inherited OnMouseEnter(Self);
end;
procedure TTRM_ImageLabel.ImageMouseLeave(Sender: TObject);
begin
if HoverLeaveImage
then
begin
Self.SubImage.Picture.Assign(FPictureLeave);
Repaint;
end;
if assigned(OnMouseLeave)
then
inherited OnMouseLeave(Self);
end;
procedure TTRM_ImageLabel.LabelClick(Sender: TObject);
begin
if assigned(OnClick)
then
inherited OnClick(Self);
end;
procedure TTRM_ImageLabel.LabelDblClick(Sender: TObject);
begin
if assigned(OnDblClick)
then
inherited OnDblClick(Self);
end;
procedure TTRM_ImageLabel.LabelMouseEnter(Sender: TObject);
begin
if FHoverLeaveLabel
then
begin
Self.SubImage.Picture.Assign(FPictureHover);
Repaint;
end;
if assigned(OnMouseEnter)
then
inherited OnMouseEnter(Self);
end;
procedure TTRM_ImageLabel.LabelMouseLeave(Sender: TObject);
begin
if FHoverLeaveLabel
then
begin
Self.SubImage.Picture.Assign(FPictureLeave);
Repaint;
end;
if assigned(OnMouseLeave)
then
inherited OnMouseLeave(Self);
end;
destructor TTRM_ImageLabel.Destroy;
begin
FSubImage.Free;
FSubLabel.Free;
FPictureDefault.Free;
FPictureHover.Free;
FPictureLeave.Free;
inherited Destroy;
end;
end.