mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-06 13:39:17 +02:00
LCL: new component TImageListImage (that displays an image from TImageList instead of a TPicture)
This commit is contained in:
Ondrej Pokorny
parent
fbfb9def5d
commit
cac82fb704
@ -8,26 +8,19 @@ unit alllclunits;
|
||||
interface
|
||||
|
||||
uses
|
||||
CheckLst, Clipbrd, ColorBox, ComCtrls, Controls, CustomTimer, DBActns,
|
||||
DBCtrls, DBGrids, DefaultTranslator, Dialogs, ExtCtrls, ExtDlgs,
|
||||
ExtGraphics, FileCtrl, Forms, Graphics, GraphUtil, Grids, HelpIntfs,
|
||||
IcnsTypes, ImageListCache, ImgList, IniPropStorage, InterfaceBase,
|
||||
IntfGraphics, LazHelpHTML, LazHelpIntf, LCLClasses, LCLIntf, LCLMemManager,
|
||||
LCLMessageGlue, LCLProc, LCLResCache, LCLStrConsts, LCLType, Menus,
|
||||
LCLUnicodeData, LCLVersion, LMessages, LResources, MaskEdit, PairSplitter,
|
||||
PopupNotifier, PostScriptCanvas, PostScriptPrinter, PostScriptUnicode,
|
||||
Printers, PropertyStorage, RubberBand, ShellCtrls, Spin, StdActns, StdCtrls,
|
||||
Themes, TmSchema, Toolwin, UTrace, XMLPropStorage, TimePopup, Messages,
|
||||
WSButtons, WSCalendar, WSCheckLst, WSComCtrls, WSControls, WSDesigner,
|
||||
WSDialogs, WSExtCtrls, WSExtDlgs, WSFactory, WSForms, WSGrids, WSImgList,
|
||||
WSLCLClasses, WSMenus, WSPairSplitter, WSProc, WSReferences, WSSpin,
|
||||
WSStdCtrls, WSToolwin, ActnList, AsyncProcess, ButtonPanel, Buttons,
|
||||
Calendar, RegisterLCL, ValEdit, LazCanvas, LazDialogs, LazRegions,
|
||||
CustomDrawn_Common, CustomDrawnControls, CustomDrawnDrawers, LazDeviceApis,
|
||||
LDockTree, LazFreeTypeIntfDrawer, CustomDrawn_WinXP, CustomDrawn_Android,
|
||||
Arrow, EditBtn, ComboEx, DBExtCtrls, CustomDrawn_Mac, CalcForm,
|
||||
LCLTranslator, GroupedEdit, LCLTaskDialog, WSLazDeviceAPIS, LCLPlatformDef,
|
||||
IndustrialBase, JSONPropStorage, LCLExceptionStackTrace, LazarusPackageIntf;
|
||||
CheckLst, Clipbrd, ColorBox, ComCtrls, Controls, CustomTimer, DBActns, DBCtrls, DBGrids, DefaultTranslator, Dialogs,
|
||||
ExtCtrls, ExtDlgs, ExtGraphics, FileCtrl, Forms, Graphics, GraphUtil, Grids, HelpIntfs, IcnsTypes, ImageListCache,
|
||||
ImgList, IniPropStorage, InterfaceBase, IntfGraphics, LazHelpHTML, LazHelpIntf, LCLClasses, LCLIntf, LCLMemManager,
|
||||
LCLMessageGlue, LCLProc, LCLResCache, LCLStrConsts, LCLType, Menus, LCLUnicodeData, LCLVersion, LMessages,
|
||||
LResources, MaskEdit, PairSplitter, PopupNotifier, PostScriptCanvas, PostScriptPrinter, PostScriptUnicode, Printers,
|
||||
PropertyStorage, RubberBand, ShellCtrls, Spin, StdActns, StdCtrls, Themes, TmSchema, Toolwin, UTrace,
|
||||
XMLPropStorage, TimePopup, Messages, WSButtons, WSCalendar, WSCheckLst, WSComCtrls, WSControls, WSDesigner,
|
||||
WSDialogs, WSExtCtrls, WSExtDlgs, WSFactory, WSForms, WSGrids, WSImgList, WSLCLClasses, WSMenus, WSPairSplitter,
|
||||
WSProc, WSReferences, WSSpin, WSStdCtrls, WSToolwin, ActnList, AsyncProcess, ButtonPanel, Buttons, Calendar,
|
||||
RegisterLCL, ValEdit, LazCanvas, LazDialogs, LazRegions, CustomDrawn_Common, CustomDrawnControls,
|
||||
CustomDrawnDrawers, LazDeviceApis, LDockTree, LazFreeTypeIntfDrawer, CustomDrawn_WinXP, CustomDrawn_Android, Arrow,
|
||||
EditBtn, ComboEx, DBExtCtrls, CustomDrawn_Mac, CalcForm, LCLTranslator, GroupedEdit, LCLTaskDialog, WSLazDeviceAPIS,
|
||||
LCLPlatformDef, IndustrialBase, JSONPropStorage, LCLExceptionStackTrace, DialogRes, LazarusPackageIntf;
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
130
lcl/extctrls.pp
130
lcl/extctrls.pp
@ -498,27 +498,20 @@ type
|
||||
end;
|
||||
|
||||
|
||||
{ TCustomImage }
|
||||
{ TCustomDrawImage }
|
||||
|
||||
TCustomImage = class(TGraphicControl)
|
||||
TCustomDrawImage = class(TGraphicControl)
|
||||
private
|
||||
FAntialiasingMode: TAntialiasingMode;
|
||||
FOnPictureChanged: TNotifyEvent;
|
||||
FOnPaintBackground: TImagePaintBackgroundEvent;
|
||||
FPicture: TPicture;
|
||||
FCenter: Boolean;
|
||||
FKeepOriginXWhenClipped: Boolean;
|
||||
FKeepOriginYWhenClipped: Boolean;
|
||||
FProportional: Boolean;
|
||||
FTransparent: Boolean;
|
||||
FStretch: Boolean;
|
||||
FStretchOutEnabled: Boolean;
|
||||
FStretchInEnabled: Boolean;
|
||||
FUseAncestorCanvas: boolean;
|
||||
FPainting: boolean;
|
||||
function GetCanvas: TCanvas;
|
||||
procedure SetAntialiasingMode(AValue: TAntialiasingMode);
|
||||
procedure SetPicture(const AValue: TPicture);
|
||||
procedure SetCenter(const AValue : Boolean);
|
||||
procedure SetKeepOriginX(AValue: Boolean);
|
||||
procedure SetKeepOriginY(AValue: Boolean);
|
||||
@ -526,30 +519,23 @@ type
|
||||
procedure SetStretch(const AValue : Boolean);
|
||||
procedure SetStretchInEnabled(AValue: Boolean);
|
||||
procedure SetStretchOutEnabled(AValue: Boolean);
|
||||
procedure SetTransparent(const AValue : Boolean);
|
||||
protected
|
||||
class procedure WSRegisterClass; override;
|
||||
procedure PictureChanged(Sender : TObject); virtual;
|
||||
procedure CalculatePreferredSize(var PreferredWidth,
|
||||
PreferredHeight: integer;
|
||||
WithThemeSpace: Boolean); override;
|
||||
class function GetControlClassDefaultSize: TSize; override;
|
||||
procedure Paint; override;
|
||||
function GetPictureSize: TSize; virtual; abstract;
|
||||
procedure PaintImage(const ARect: TRect); virtual; abstract;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
property Canvas: TCanvas read GetCanvas;
|
||||
function DestRect: TRect; virtual;
|
||||
procedure Invalidate; override;
|
||||
public
|
||||
property AntialiasingMode: TAntialiasingMode read FAntialiasingMode write SetAntialiasingMode default amDontCare;
|
||||
property Align;
|
||||
property AutoSize;
|
||||
property Center: Boolean read FCenter write SetCenter default False;
|
||||
property KeepOriginXWhenClipped: Boolean read FKeepOriginXWhenClipped write SetKeepOriginX default False;
|
||||
property KeepOriginYWhenClipped: Boolean read FKeepOriginYWhenClipped write SetKeepOriginY default False;
|
||||
property Constraints;
|
||||
property Picture: TPicture read FPicture write SetPicture;
|
||||
property Visible;
|
||||
property OnClick;
|
||||
property OnMouseDown;
|
||||
@ -563,12 +549,42 @@ type
|
||||
property Stretch: Boolean read FStretch write SetStretch default False;
|
||||
property StretchOutEnabled: Boolean read FStretchOutEnabled write SetStretchOutEnabled default True;
|
||||
property StretchInEnabled: Boolean read FStretchInEnabled write SetStretchInEnabled default True;
|
||||
property Transparent: Boolean read FTransparent write SetTransparent default False;
|
||||
property Proportional: Boolean read FProportional write SetProportional default False;
|
||||
property OnPictureChanged: TNotifyEvent read FOnPictureChanged write FOnPictureChanged;
|
||||
property OnPaintBackground: TImagePaintBackgroundEvent read FOnPaintBackground write FOnPaintBackground;
|
||||
end;
|
||||
|
||||
{ TCustomImage }
|
||||
|
||||
TCustomImage = class(TCustomDrawImage)
|
||||
private
|
||||
FAntialiasingMode: TAntialiasingMode;
|
||||
FPicture: TPicture;
|
||||
FTransparent: Boolean;
|
||||
|
||||
function GetCanvas: TCanvas;
|
||||
procedure SetAntialiasingMode(AValue: TAntialiasingMode);
|
||||
procedure SetPicture(const AValue: TPicture);
|
||||
procedure SetTransparent(const AValue : Boolean);
|
||||
protected
|
||||
class procedure WSRegisterClass; override;
|
||||
procedure CalculatePreferredSize(var PreferredWidth,
|
||||
PreferredHeight: integer;
|
||||
WithThemeSpace: Boolean); override;
|
||||
procedure PictureChanged(Sender: TObject); override;
|
||||
function GetPictureSize: TSize; override;
|
||||
procedure Paint; override;
|
||||
procedure PaintImage(const ARect: TRect); override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
public
|
||||
property Canvas: TCanvas read GetCanvas;
|
||||
public
|
||||
property AntialiasingMode: TAntialiasingMode read FAntialiasingMode write SetAntialiasingMode default amDontCare;
|
||||
property Picture: TPicture read FPicture write SetPicture;
|
||||
property Transparent: Boolean read FTransparent write SetTransparent default False;
|
||||
end;
|
||||
|
||||
{ TImage }
|
||||
|
||||
@ -622,6 +638,80 @@ type
|
||||
end;
|
||||
|
||||
|
||||
{ TCustomImageListImage }
|
||||
|
||||
TCustomImageListImage = class(TCustomDrawImage)
|
||||
private
|
||||
FImageIndex: Integer;
|
||||
FImages: TCustomImageList;
|
||||
FImageWidth: Integer;
|
||||
procedure SetImageIndex(const AImageIndex: Integer);
|
||||
procedure SetImages(const AImages: TCustomImageList);
|
||||
procedure SetImageWidth(const AImageWidth: Integer);
|
||||
protected
|
||||
procedure CalculatePreferredSize(var PreferredWidth,
|
||||
PreferredHeight: integer;
|
||||
WithThemeSpace: Boolean); override;
|
||||
function GetPictureSize: TSize; override;
|
||||
procedure PaintImage(const ARect: TRect); override;
|
||||
public
|
||||
property ImageIndex: Integer read FImageIndex write SetImageIndex;
|
||||
property ImageWidth: Integer read FImageWidth write SetImageWidth;
|
||||
property Images: TCustomImageList read FImages write SetImages;
|
||||
end;
|
||||
|
||||
|
||||
{ TImageListImage }
|
||||
|
||||
TImageListImage = class(TCustomImageListImage)
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property AutoSize;
|
||||
property BorderSpacing;
|
||||
property Center;
|
||||
property Constraints;
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property ImageIndex;
|
||||
property ImageWidth; // a custom ImageWidth for the Images image list
|
||||
property Images;
|
||||
property KeepOriginXWhenClipped;
|
||||
property KeepOriginYWhenClipped;
|
||||
property OnChangeBounds;
|
||||
property OnClick;
|
||||
property OnContextPopup;
|
||||
property OnDblClick;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelDown;
|
||||
property OnMouseWheelUp;
|
||||
property OnMouseWheelHorz;
|
||||
property OnMouseWheelLeft;
|
||||
property OnMouseWheelRight;
|
||||
property OnPaint;
|
||||
property OnPaintBackground;
|
||||
property OnResize;
|
||||
property OnStartDrag;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property Proportional;
|
||||
property ShowHint;
|
||||
property Stretch;
|
||||
property StretchOutEnabled;
|
||||
property StretchInEnabled;
|
||||
property Visible;
|
||||
end;
|
||||
|
||||
|
||||
{ TBevel }
|
||||
|
||||
TBevelStyle = (bsLowered, bsRaised);
|
||||
@ -1711,7 +1801,7 @@ end;
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('Standard',[TRadioGroup,TCheckGroup,TPanel]);
|
||||
RegisterComponents('Additional',[TImage,TShape,TBevel,TPaintBox,
|
||||
RegisterComponents('Additional',[TImage,TImageListImage,TShape,TBevel,TPaintBox,
|
||||
TNotebook, TLabeledEdit, TSplitter, TTrayIcon, TControlBar, TFlowPanel]);
|
||||
RegisterComponents('System',[TTimer,TIdleTimer]);
|
||||
RegisterNoIcon([TPage]);
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{%MainUnit ../extctrls.pp}
|
||||
|
||||
{ TCustomImage
|
||||
{ TCustomDrawImage
|
||||
|
||||
*****************************************************************************
|
||||
This file is part of the Lazarus Component Library (LCL)
|
||||
@ -10,7 +10,7 @@
|
||||
*****************************************************************************
|
||||
}
|
||||
|
||||
constructor TCustomImage.Create(AOwner: TComponent);
|
||||
constructor TCustomDrawImage.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
ControlStyle:= [csCaptureMouse, csClickEvents, csDoubleClicks];
|
||||
@ -22,143 +22,67 @@ begin
|
||||
FStretch := False;
|
||||
FStretchOutEnabled := True;
|
||||
FStretchInEnabled := True;
|
||||
FTransparent := False;
|
||||
FPicture := TPicture.Create;
|
||||
FPicture.OnChange := @PictureChanged;
|
||||
FUseAncestorCanvas := False;
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
end;
|
||||
|
||||
destructor TCustomImage.Destroy;
|
||||
begin
|
||||
FPicture.OnChange := nil;
|
||||
FPicture.Graphic := nil;
|
||||
FPicture.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TCustomImage.GetCanvas: TCanvas;
|
||||
var
|
||||
TempBitmap: TBitmap;
|
||||
begin
|
||||
//debugln('TCustomImage.GetCanvas A ',DbgSName(Self),' ',DbgSName(FPicture.Graphic));
|
||||
if not FUseAncestorCanvas and (FPicture.Graphic = nil) then
|
||||
begin
|
||||
// make a new bitmap to draw on
|
||||
TempBitmap := TBitmap.Create;
|
||||
try
|
||||
TempBitmap.Width := Width;
|
||||
TempBitmap.Height := Height;
|
||||
FPicture.Graphic := TempBitmap;
|
||||
finally
|
||||
TempBitmap.Free;
|
||||
end;
|
||||
end;
|
||||
//debugln(['TCustomImage.GetCanvas B ',DbgSName(Self),' ',DbgSName(FPicture.Graphic),' FUseParentCanvas=',FUseAncestorCanvas]);
|
||||
// try draw on the bitmap, not on the form's canvas
|
||||
if not FUseAncestorCanvas and (FPicture.Graphic is TBitmap) then
|
||||
Result := TBitmap(FPicture.Graphic).Canvas
|
||||
else
|
||||
Result := inherited Canvas;
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetAntialiasingMode(AValue: TAntialiasingMode);
|
||||
begin
|
||||
if FAntialiasingMode = AValue then Exit;
|
||||
FAntialiasingMode := AValue;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetKeepOriginX(AValue: Boolean);
|
||||
procedure TCustomDrawImage.SetKeepOriginX(AValue: Boolean);
|
||||
begin
|
||||
if FKeepOriginXWhenClipped=AValue then Exit;
|
||||
FKeepOriginXWhenClipped:=AValue;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetKeepOriginY(AValue: Boolean);
|
||||
procedure TCustomDrawImage.SetKeepOriginY(AValue: Boolean);
|
||||
begin
|
||||
if FKeepOriginYWhenClipped=AValue then Exit;
|
||||
FKeepOriginYWhenClipped:=AValue;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetPicture(const AValue: TPicture);
|
||||
begin
|
||||
if FPicture=AValue then exit;
|
||||
//the OnChange of the picture gets called and
|
||||
// notifies this TCustomImage that something changed.
|
||||
FPicture.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetStretch(const AValue : Boolean);
|
||||
procedure TCustomDrawImage.SetStretch(const AValue : Boolean);
|
||||
begin
|
||||
if FStretch = AValue then exit;
|
||||
FStretch := AValue;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetStretchInEnabled(AValue: Boolean);
|
||||
procedure TCustomDrawImage.SetStretchInEnabled(AValue: Boolean);
|
||||
begin
|
||||
if FStretchInEnabled = AValue then Exit;
|
||||
FStretchInEnabled := AValue;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetStretchOutEnabled(AValue: Boolean);
|
||||
procedure TCustomDrawImage.SetStretchOutEnabled(AValue: Boolean);
|
||||
begin
|
||||
if FStretchOutEnabled = AValue then Exit;
|
||||
FStretchOutEnabled := AValue;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetTransparent(const AValue : Boolean);
|
||||
begin
|
||||
if FTransparent = AValue then exit;
|
||||
FTransparent := AValue;
|
||||
if (FPicture.Graphic <> nil) and (FPicture.Graphic.Transparent <> FTransparent)
|
||||
then FPicture.Graphic.Transparent := FTransparent
|
||||
else PictureChanged(Self);
|
||||
end;
|
||||
|
||||
class procedure TCustomImage.WSRegisterClass;
|
||||
begin
|
||||
inherited WSRegisterClass;
|
||||
RegisterCustomImage;
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetCenter(const AValue : Boolean);
|
||||
procedure TCustomDrawImage.SetCenter(const AValue : Boolean);
|
||||
begin
|
||||
if FCenter = AValue then exit;
|
||||
FCenter := AValue;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetProportional(const AValue: Boolean);
|
||||
procedure TCustomDrawImage.SetProportional(const AValue: Boolean);
|
||||
begin
|
||||
if FProportional = AValue then exit;
|
||||
FProportional := AValue;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.PictureChanged(Sender : TObject);
|
||||
procedure TCustomDrawImage.PictureChanged(Sender : TObject);
|
||||
begin
|
||||
if Picture.Graphic <> nil
|
||||
then begin
|
||||
if AutoSize
|
||||
then begin
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
end;
|
||||
Picture.Graphic.Transparent := FTransparent;
|
||||
end;
|
||||
invalidate;
|
||||
Invalidate;
|
||||
if Assigned(OnPictureChanged) then
|
||||
OnPictureChanged(Self);
|
||||
end;
|
||||
|
||||
function TCustomImage.DestRect: TRect;
|
||||
function TCustomDrawImage.DestRect: TRect;
|
||||
var
|
||||
PicWidth: Integer;
|
||||
PicHeight: Integer;
|
||||
@ -169,8 +93,8 @@ var
|
||||
ChangeX, ChangeY: Integer;
|
||||
PicInside, PicOutside, PicOutsidePartial: boolean;
|
||||
begin
|
||||
PicWidth := Picture.Width;
|
||||
PicHeight := Picture.Height;
|
||||
PicWidth := GetPictureSize.Width;
|
||||
PicHeight := GetPictureSize.Height;
|
||||
ImgWidth := ClientWidth;
|
||||
ImgHeight := ClientHeight;
|
||||
if (PicWidth=0) or (PicHeight=0) then Exit(Rect(0, 0, 0, 0));
|
||||
@ -209,30 +133,23 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomImage.Invalidate;
|
||||
procedure TCustomDrawImage.Invalidate;
|
||||
begin
|
||||
if FPainting then exit;
|
||||
inherited Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomImage.CalculatePreferredSize(var PreferredWidth,
|
||||
PreferredHeight: integer; WithThemeSpace: Boolean);
|
||||
begin
|
||||
PreferredWidth := Picture.Width;
|
||||
PreferredHeight := Picture.Height;
|
||||
end;
|
||||
|
||||
class function TCustomImage.GetControlClassDefaultSize: TSize;
|
||||
class function TCustomDrawImage.GetControlClassDefaultSize: TSize;
|
||||
begin
|
||||
Result.CX := 90;
|
||||
Result.CY := 90;
|
||||
end;
|
||||
|
||||
procedure TCustomImage.Paint;
|
||||
procedure TCustomDrawImage.Paint;
|
||||
|
||||
procedure DrawFrame;
|
||||
begin
|
||||
with inherited Canvas do
|
||||
with Canvas do
|
||||
begin
|
||||
Pen.Color := clBlack;
|
||||
Pen.Style := psDash;
|
||||
@ -246,35 +163,172 @@ procedure TCustomImage.Paint;
|
||||
|
||||
var
|
||||
R: TRect;
|
||||
C: TCanvas;
|
||||
begin
|
||||
// detect loop
|
||||
if FUseAncestorCanvas then exit;
|
||||
|
||||
if csDesigning in ComponentState
|
||||
then DrawFrame;
|
||||
|
||||
if Picture.Graphic = nil
|
||||
then Exit;
|
||||
|
||||
C := inherited Canvas;
|
||||
R := DestRect;
|
||||
C.AntialiasingMode := FAntialiasingMode;
|
||||
FPainting:=true;
|
||||
try
|
||||
if Assigned(FOnPaintBackground) then
|
||||
FOnPaintBackground(Self, C, R);
|
||||
C.StretchDraw(R, Picture.Graphic);
|
||||
FOnPaintBackground(Self, Canvas, R);
|
||||
PaintImage(R);
|
||||
finally
|
||||
FPainting:=false;
|
||||
end;
|
||||
|
||||
FUseAncestorCanvas := True;
|
||||
try
|
||||
inherited Paint;
|
||||
finally
|
||||
FUseAncestorCanvas := False;
|
||||
inherited Paint;
|
||||
end;
|
||||
|
||||
{ TCustomImage }
|
||||
|
||||
constructor TCustomImage.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
FPicture := TPicture.Create;
|
||||
FPicture.OnChange := @PictureChanged;
|
||||
end;
|
||||
|
||||
procedure TCustomImage.CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean);
|
||||
begin
|
||||
PreferredWidth := Picture.Width;
|
||||
PreferredHeight := Picture.Height;
|
||||
end;
|
||||
|
||||
destructor TCustomImage.Destroy;
|
||||
begin
|
||||
FPicture.OnChange := nil;
|
||||
FPicture.Graphic := nil;
|
||||
FPicture.Free;
|
||||
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TCustomImage.GetCanvas: TCanvas;
|
||||
var
|
||||
TempBitmap: TBitmap;
|
||||
begin
|
||||
//debugln('TCustomDrawImage.GetCanvas A ',DbgSName(Self),' ',DbgSName(FPicture.Graphic));
|
||||
if (FPicture.Graphic = nil) then
|
||||
begin
|
||||
// make a new bitmap to draw on
|
||||
TempBitmap := TBitmap.Create;
|
||||
try
|
||||
TempBitmap.Width := Width;
|
||||
TempBitmap.Height := Height;
|
||||
FPicture.Graphic := TempBitmap;
|
||||
finally
|
||||
TempBitmap.Free;
|
||||
end;
|
||||
end;
|
||||
//debugln(['TCustomDrawImage.GetCanvas B ',DbgSName(Self),' ',DbgSName(FPicture.Graphic),' FUseParentCanvas=',FUseAncestorCanvas]);
|
||||
// try draw on the bitmap, not on the form's canvas
|
||||
if (FPicture.Graphic is TBitmap) then
|
||||
Result := TBitmap(FPicture.Graphic).Canvas
|
||||
else
|
||||
Result := inherited Canvas;
|
||||
end;
|
||||
|
||||
function TCustomImage.GetPictureSize: TSize;
|
||||
begin
|
||||
Result := TSize.Create(Picture.Width, Picture.Height);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.Paint;
|
||||
begin
|
||||
inherited Canvas.AntialiasingMode := FAntialiasingMode;
|
||||
inherited Paint;
|
||||
end;
|
||||
|
||||
procedure TCustomImage.PaintImage(const ARect: TRect);
|
||||
begin
|
||||
if Assigned(Picture.Graphic) then
|
||||
inherited Canvas.StretchDraw(ARect, Picture.Graphic);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.PictureChanged(Sender: TObject);
|
||||
begin
|
||||
if Picture.Graphic <> nil then
|
||||
begin
|
||||
if AutoSize then
|
||||
begin
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
end;
|
||||
Picture.Graphic.Transparent := FTransparent;
|
||||
end;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetAntialiasingMode(AValue: TAntialiasingMode);
|
||||
begin
|
||||
if FAntialiasingMode = AValue then Exit;
|
||||
FAntialiasingMode := AValue;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetPicture(const AValue: TPicture);
|
||||
begin
|
||||
if FPicture=AValue then exit;
|
||||
//the OnChange of the picture gets called and
|
||||
// notifies this TCustomDrawImage that something changed.
|
||||
FPicture.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TCustomImage.SetTransparent(const AValue: Boolean);
|
||||
begin
|
||||
if FTransparent = AValue then exit;
|
||||
FTransparent := AValue;
|
||||
if (FPicture.Graphic <> nil) and (FPicture.Graphic.Transparent <> FTransparent)
|
||||
then FPicture.Graphic.Transparent := FTransparent
|
||||
else PictureChanged(Self);
|
||||
end;
|
||||
|
||||
class procedure TCustomImage.WSRegisterClass;
|
||||
begin
|
||||
inherited WSRegisterClass;
|
||||
RegisterCustomImage;
|
||||
end;
|
||||
|
||||
{ TCustomImageListImage }
|
||||
|
||||
procedure TCustomImageListImage.CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
WithThemeSpace: Boolean);
|
||||
begin
|
||||
inherited CalculatePreferredSize(PreferredWidth, PreferredHeight, WithThemeSpace);
|
||||
end;
|
||||
|
||||
function TCustomImageListImage.GetPictureSize: TSize;
|
||||
begin
|
||||
Result := Images.SizeForPPI[ImageWidth, Font.PixelsPerInch];
|
||||
end;
|
||||
|
||||
procedure TCustomImageListImage.PaintImage(const ARect: TRect);
|
||||
begin
|
||||
if Assigned(Images) and (ImageIndex>=0) then
|
||||
Images.StretchDraw(Canvas, ImageIndex, ARect);
|
||||
end;
|
||||
|
||||
procedure TCustomImageListImage.SetImageIndex(const AImageIndex: Integer);
|
||||
begin
|
||||
if FImageIndex = AImageIndex then Exit;
|
||||
FImageIndex := AImageIndex;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImageListImage.SetImages(const AImages: TCustomImageList);
|
||||
begin
|
||||
if FImages = AImages then Exit;
|
||||
FImages := AImages;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TCustomImageListImage.SetImageWidth(const AImageWidth: Integer);
|
||||
begin
|
||||
if FImageWidth = AImageWidth then Exit;
|
||||
FImageWidth := AImageWidth;
|
||||
PictureChanged(Self);
|
||||
end;
|
||||
|
||||
// included by extctrls.pp
|
||||
|
||||
Loading…
Reference in New Issue
Block a user