From cac82fb704f49ca2ff797deccb60e92feac837b6 Mon Sep 17 00:00:00 2001 From: Ondrej Pokorny Date: Wed, 28 Sep 2022 16:10:01 +0200 Subject: [PATCH] LCL: new component TImageListImage (that displays an image from TImageList instead of a TPicture) --- lcl/alllclunits.pp | 33 ++--- lcl/extctrls.pp | 130 +++++++++++++--- lcl/include/customimage.inc | 288 +++++++++++++++++++++--------------- 3 files changed, 294 insertions(+), 157 deletions(-) diff --git a/lcl/alllclunits.pp b/lcl/alllclunits.pp index c59fb7a4c8..8d697b87dd 100644 --- a/lcl/alllclunits.pp +++ b/lcl/alllclunits.pp @@ -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 diff --git a/lcl/extctrls.pp b/lcl/extctrls.pp index ea699df77a..79cf573fa3 100644 --- a/lcl/extctrls.pp +++ b/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]); diff --git a/lcl/include/customimage.inc b/lcl/include/customimage.inc index b8412a67b4..232e120f6c 100644 --- a/lcl/include/customimage.inc +++ b/lcl/include/customimage.inc @@ -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