paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 19:38:04 +02:00
Code Issues Packages Projects Releases Wiki Activity
a3b65673ed
lazarus/lcl/imglist.pp

482 lines
22 KiB
ObjectPascal
Raw Blame History

{
/***************************************************************************
imglist.pp
----------
Component Library TCustomImageList, TChangeLink Controls
Initial Revision : Fri Aug 16 21:00:00 CET 1999
***************************************************************************/
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
{
@author(TCustomImageList - Marc Weustink <weus@quicknet.nl>)
@author(TChangeLink - Marc Weustink <weus@quicknet.nl>)
@created(16-Aug-1999)
@lastmod(26-feb-2003)
Detailed description of the Unit.
History
26-feb-2003 Olivier Guilbaud <golivier@free.fr>
- Add TCustomImageList.Assign()
- Add TCustomImageList.WriteData()
- Add TCustomImageList.ReadData()
- Add override TCustomImageList.DefineProperties()
Warning : the delphi or kylix format of datas is not compatible.
- Modify Delete and Clear for preserve memory
}
unit ImgList;
{$mode objfpc}{$H+}
{$modeswitch advancedrecords}
interface
{$ifdef Trace}
{$ASSERTIONS ON}
{$endif}
uses
// RTL + FCL
Types, math, SysUtils, Classes, RtlConsts, Contnrs, zstream, Laz_AVL_Tree,
FPReadBMP, FPimage, FPImgCanv, FPCanvas,
// LCL
LCLStrConsts, LCLIntf, LResources, LCLType, LCLProc, LCLClasses,
Graphics, IntfGraphics, WSReferences,
// LazUtils
GraphType, FPCAdds, LazLoggerBase, LazTracer, LazUtilities, AvgLvlTree;
type
TImageIndex = type integer;
{ TChangeLink }
{
@abstract(Use a TChangelink to get notified of imagelist changes)
Introduced by Marc Weustink <weus@quicknet.nl>
Currently maintained by Marc Weustink <weus@quicknet.nl>
}
TCustomImageList = class; //forward declaration
TDestroyResolutionHandleEvent = procedure(Sender: TCustomImageList; AWidth: Integer; AReferenceHandle: TLCLHandle) of object;
TChangeLink = class(TObject)
private
FSender: TCustomImageList;
FOnChange: TNotifyEvent;
FOnDestroyResolutionHandle: TDestroyResolutionHandleEvent;
procedure DoDestroyResolutionReference(const AWidth: Integer; AResolutionReference: TLCLHandle);
public
destructor Destroy; override;
procedure Change; virtual;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnDestroyResolutionHandle: TDestroyResolutionHandleEvent read FOnDestroyResolutionHandle write FOnDestroyResolutionHandle;
property Sender: TCustomImageList read FSender write FSender;
end;
{ TCustomImageList }
{
@abstract(Contains a list of images)
Introduced by Marc Weustink <marc@dommelstein.net>
Delphis TCustomImageList is based on the Win32 imagelists which has
internally only one bitmap to hold all images. This reduces handle
allocation.
The original TCustomImageList implementation was LCL only based, so for
other platforms the single bitmap implementation had some speed drawbacks.
Therefore it was implemented as list of bitmaps, however it doesnt reduce
handle allocation.
In its current form, the imagelist is again based on a 32bit RGBA raw
imagedata and the widgetset is notified when images are added or removed,
so the widgetset can create its own optimal storage. The LCL keeps only the
data, so all transparency info will be stored cross platform. (not all
platforms have a 8bit alpha channel).
NOTE: due to its implementation, the TCustomImageList is not a TBitmap
collection. If a fast storage of bitmaps is needed, create your own list!
}
// Some temp rework defines, for old functionality both need so be set
TDrawingStyle = (dsFocus, dsSelected, dsNormal, dsTransparent);
TImageType = (itImage, itMask);
TOverlay = 0..14; // windows limitation
TCustomImageListResolution = class(TLCLReferenceComponent)
private
FWidth: Integer;
FHeight: Integer;
FData: array of TRGBAQuad;
FReference: TWSCustomImageListReference;
FAllocCount: Integer;
FImageList: TCustomImageList;
FCount: Integer;
FAutoCreatedInDesignTime: Boolean;
procedure AllocData(ACount: Integer);
function GetReference: TWSCustomImageListReference;
function Add(Image, Mask: TCustomBitmap): Integer;
procedure InternalInsert(AIndex: Integer; AData: PRGBAQuad); overload;
procedure InternalMove(ACurIndex, ANewIndex: Cardinal; AIgnoreCurrent: Boolean);
procedure InternalReplace(AIndex: Integer; AData: PRGBAQuad);
function InternalSetData(AIndex: Integer; AData: PRGBAQuad): PRGBAQuad;
procedure CheckIndex(AIndex: Integer; AForInsert: Boolean = False);
procedure Clear;
procedure Delete(AIndex: Integer);
procedure GetFullRawImage(out Image: TRawImage);
procedure AddImages(AValue: TCustomImageListResolution);
procedure WriteData(AStream: TStream; const ACompress: Boolean);
procedure ReadData(AStream: TStream);
protected
function GetReferenceHandle: THandle; override;
function WSCreateReference(AParams: TCreateParams): PWSReference; override;
class procedure WSRegisterClass; override;
procedure ReferenceDestroying; override;
public
destructor Destroy; override;
public
function GetHotSpot: TPoint; virtual;
procedure FillDescription(out ADesc: TRawImageDescription);
procedure GetBitmap(Index: Integer; Image: TCustomBitmap); overload;
procedure GetBitmap(Index: Integer; Image: TCustomBitmap; AEffect: TGraphicsDrawEffect); overload;
procedure GetIcon(Index: Integer; Image: TIcon; AEffect: TGraphicsDrawEffect); overload;
procedure GetIcon(Index: Integer; Image: TIcon); overload;
procedure GetFullBitmap(Image: TCustomBitmap; AEffect: TGraphicsDrawEffect = gdeNormal);
procedure GetRawImage(Index: Integer; out Image: TRawImage);
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; AEnabled: Boolean = True); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; ADrawEffect: TGraphicsDrawEffect); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; ADrawingStyle: TDrawingStyle; AImageType: TImageType;
AEnabled: Boolean = True); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; ADrawingStyle: TDrawingStyle; AImageType: TImageType;
ADrawEffect: TGraphicsDrawEffect); overload; virtual;
procedure StretchDraw(Canvas: TCanvas; Index: Integer; ARect: TRect; Enabled: Boolean = True);
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; AEnabled: Boolean = True); overload;
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; ADrawEffect: TGraphicsDrawEffect); overload;
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; ADrawingStyle:
TDrawingStyle; AImageType: TImageType; ADrawEffect: TGraphicsDrawEffect); overload;
property ImageList: TCustomImageList read FImageList;
property Width: Integer read FWidth;
property Height: Integer read FHeight;
property Count: Integer read FCount;
property AutoCreatedInDesignTime: Boolean read FAutoCreatedInDesignTime write FAutoCreatedInDesignTime;
property Reference: TWSCustomImageListReference read GetReference;
end;
{ TScaledImageListResolution }
TScaledImageListResolution = record
private
FResolution: TCustomImageListResolution;
FScaleFactor: Double;
FWidth: Integer;
FHeight: Integer;
function GetCount: Integer;
function GetSize: TSize;
function GetValid: Boolean;
public
class function Create(AResolution: TCustomImageListResolution;
const AScaleFactor: Double): TScaledImageListResolution; static; // FPC record constructor bug
procedure GetBitmap(Index: Integer; Image: TCustomBitmap); overload;
procedure GetBitmap(Index: Integer; Image: TCustomBitmap; AEffect: TGraphicsDrawEffect); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; AEnabled: Boolean = True); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; ADrawEffect: TGraphicsDrawEffect); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; ADrawingStyle: TDrawingStyle; AImageType: TImageType;
AEnabled: Boolean = True); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; ADrawingStyle: TDrawingStyle; AImageType: TImageType;
ADrawEffect: TGraphicsDrawEffect); overload;
procedure StretchDraw(Canvas: TCanvas; Index: Integer; ARect: TRect; Enabled: Boolean = True);
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; AEnabled: Boolean = True); overload;
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; ADrawEffect: TGraphicsDrawEffect); overload;
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; ADrawingStyle:
TDrawingStyle; AImageType: TImageType; ADrawEffect: TGraphicsDrawEffect); overload;
property Width: Integer read FWidth;
property Height: Integer read FHeight;
property Size: TSize read GetSize;
property Resolution: TCustomImageListResolution read FResolution;
property Count: Integer read GetCount;
property Valid: Boolean read GetValid;
end;
TCustomImageListResolutionClass = class of TCustomImageListResolution;
TCustomImageListResolutions = class(TObject)
private
FList: TObjectList;
FImageList: TCustomImageList;
FResolutionClass: TCustomImageListResolutionClass;
function Find(const AImageWidth: Integer; out Index: Integer): Boolean;
function GetImageLists(const AImageWidth: Integer): TCustomImageListResolution;
function GetImageLists(const AImageWidth: Integer; const AScaleFromExisting,
AutoCreatedInDesignTime: Boolean): TCustomImageListResolution;
function GetItems(const AIndex: Integer): TCustomImageListResolution;
function GetCount: Integer;
function FindBestToCopyFrom(const ATargetWidth, AIgnoreIndex: Integer): Integer;
public
constructor Create(const AImageList: TCustomImageList; const AResolutionClass: TCustomImageListResolutionClass);
destructor Destroy; override;
public
function FindBestToScaleFrom(const ATargetWidth: Integer): Integer;
procedure Delete(const AIndex: Integer);
procedure Clear;
property ImageLists[const AImageWidth: Integer]: TCustomImageListResolution read GetImageLists;
property Items[const AIndex: Integer]: TCustomImageListResolution read GetItems; default;
property Count: Integer read GetCount;
end;
TCustomImageListResolutionEnumerator = class
private
FCurrent: Integer;
FImgList: TCustomImageList;
FDesc: Boolean;
function GetCurrent: TCustomImageListResolution;
public
function GetEnumerator: TCustomImageListResolutionEnumerator;
constructor Create(AImgList: TCustomImageList; ADesc: Boolean);
function MoveNext: Boolean;
property Current: TCustomImageListResolution read GetCurrent;
end;
TCustomImageListGetWidthForPPI = procedure(Sender: TCustomImageList;
AImageWidth, APPI: Integer; var AResultWidth: Integer) of object;
TCustomImageList = class(TLCLComponent)
private
FDrawingStyle: TDrawingStyle;
FData: TCustomImageListResolutions;
FImageType: TImageType;
FHeight: Integer;
FMasked: boolean;
FShareImages: Boolean;
FWidth: Integer;
FAllocBy: Integer;
FBlendColor: TColor;
FOnChange: TNotifyEvent;
FChangeLinkList: TList;
FBkColor: TColor;
FChanged: boolean;
FUpdateCount: integer;
FOverlays: array[TOverlay] of Integer;
fHasOverlays: boolean;
FOnGetWidthForPPI: TCustomImageListGetWidthForPPI;
FScaled: Boolean;
procedure NotifyChangeLink;
procedure SetBkColor(const Value: TColor);
procedure SetDrawingStyle(const AValue: TDrawingStyle);
procedure SetHeight(const Value: Integer);
procedure SetMasked(const AValue: boolean);
procedure SetShareImages(const AValue: Boolean);
procedure SetWidth(const Value: Integer);
function GetReference(AImageWidth: Integer): TWSCustomImageListReference;
function GetReferenceForPPI(AImageWidth, APPI: Integer): TWSCustomImageListReference;
function GetResolutionForPPI(AImageWidth, APPI: Integer;
const ACanvasScaleFactor: Double): TScaledImageListResolution;
function GetWidthForPPI(AImageWidth, APPI: Integer): Integer;
function GetHeightForPPI(AImageWidth, APPI: Integer): Integer;
function GetHeightForWidth(AWidth: Integer): Integer;
function GetCount: Integer;
function GetSizeForPPI(AImageWidth, APPI: Integer): TSize;
function GetBestIconIndexForSize(AIcon: TCustomIcon; AWidth: Integer): Integer; // the icon must be sorted
function GetResolutionByIndex(AIndex: Integer): TCustomImageListResolution;
function GetResolutionCount: Integer;
procedure CreateDefaultResolution;
procedure DoDestroyResolutionReference(const AWidth: Integer; AResolutionReference: TLCLHandle);
protected
function GetResolution(AImageWidth: Integer): TCustomImageListResolution;
function GetResolutionClass: TCustomImageListResolutionClass; virtual;
procedure CheckIndex(AIndex: Integer; AForInsert: Boolean = False);
procedure Initialize; virtual;
procedure DefineProperties(Filer: TFiler); override;
procedure SetWidthHeight(NewWidth, NewHeight: integer);
procedure ClearOverlays;
public
constructor Create(AOwner: TComponent); override;
constructor CreateSize(AWidth, AHeight: Integer);
destructor Destroy; override;
class procedure ScaleImage(const ABitmap, AMask: TCustomBitmap;
TargetWidth, TargetHeight: Integer; var AData: TRGBAQuadArray);
class procedure ScaleImage(const ABitmap, AMask: TCustomBitmap;
SourceRect: TRect; TargetWidth, TargetHeight: Integer; var AData: TRGBAQuadArray);
class procedure ScaleImage(const ABitmap, AMask: HBITMAP;
SourceRect: TRect; TargetWidth, TargetHeight: Integer; var AData: TRGBAQuadArray);
procedure AssignTo(Dest: TPersistent); override;
procedure Assign(Source: TPersistent); override;
procedure WriteData(AStream: TStream); virtual;
procedure ReadData(AStream: TStream); virtual;
procedure WriteAdvData(AStream: TStream); virtual;
procedure ReadAdvData(AStream: TStream); virtual;
function Equals(Obj: TObject): boolean;
{$IF FPC_FULLVERSION>=20402}override;{$ENDIF}
procedure BeginUpdate;
procedure EndUpdate;
function Add(Image, Mask: TCustomBitmap): Integer;
function AddMultipleResolutions(Images: array of TCustomBitmap): Integer; // always pass sorted array from smallest to biggest
function AddMultipleResolutions(Images: array of TRasterImage): Integer; // always pass sorted array from smallest to biggest
function AddSliced(Image: TCustomBitmap; AHorizontalCount, AVerticalCount: Integer): Integer;
function AddSlice(Image: TCustomBitmap; AImageRect: TRect): Integer;
function AddSliceCentered(Image: TCustomBitmap): Integer;
function AddIcon(Image: TCustomIcon): Integer;
procedure AddImages(AValue: TCustomImageList);
function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
function AddLazarusResource(const ResourceName: string; MaskColor: TColor = clNone): integer;
function AddResourceName(Instance: THandle; const ResourceName: string; MaskColor: TColor = clNone): integer;
procedure Change;
procedure Clear;
procedure Delete(AIndex: Integer);
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; AEnabled: Boolean = True); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; ADrawEffect: TGraphicsDrawEffect); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; ADrawingStyle: TDrawingStyle; AImageType: TImageType;
AEnabled: Boolean = True); overload;
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: Integer; ADrawingStyle: TDrawingStyle; AImageType: TImageType;
ADrawEffect: TGraphicsDrawEffect); overload;
procedure DrawForPPI(ACanvas: TCanvas; AX, AY, AIndex: Integer;
AImageWidthAt96PPI, ATargetPPI: Integer; ACanvasFactor: Double; AEnabled: Boolean = True); overload;
procedure DrawForPPI(ACanvas: TCanvas; AX, AY, AIndex: Integer;
AImageWidthAt96PPI, ATargetPPI: Integer; ACanvasFactor: Double; ADrawEffect: TGraphicsDrawEffect); overload;
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; AEnabled: Boolean = True); overload;
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; ADrawEffect: TGraphicsDrawEffect); overload;
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; ADrawingStyle:
TDrawingStyle; AImageType: TImageType; ADrawEffect: TGraphicsDrawEffect); overload;
procedure GetBitmap(Index: Integer; Image: TCustomBitmap); overload;
procedure GetBitmap(Index: Integer; Image: TCustomBitmap; AEffect: TGraphicsDrawEffect); overload;
procedure GetFullBitmap(Image: TCustomBitmap; AEffect: TGraphicsDrawEffect = gdeNormal);
procedure GetFullRawImage(out Image: TRawImage);
procedure GetIcon(Index: Integer; Image: TIcon; AEffect: TGraphicsDrawEffect); overload;
procedure GetIcon(Index: Integer; Image: TIcon); overload;
procedure GetRawImage(Index: Integer; out Image: TRawImage);
function GetHotSpot: TPoint;
procedure Insert(AIndex: Integer; AImage, AMask: TCustomBitmap);
procedure InsertIcon(AIndex: Integer; AIcon: TCustomIcon);
procedure InsertMasked(Index: Integer; AImage: TCustomBitmap; MaskColor: TColor);
procedure Move(ACurIndex, ANewIndex: Integer);
procedure Overlay(AIndex: Integer; Overlay: TOverlay);
property HasOverlays: boolean read fHasOverlays;
procedure Replace(AIndex: Integer; AImage, AMask: TCustomBitmap; const AllResolutions: Boolean = True);
procedure ReplaceSlice(AIndex: Integer; Image: TCustomBitmap; AImageRect: TRect; const AllResolutions: Boolean = True);
procedure ReplaceSliceCentered(AIndex, AImageWidth: Integer; Image: TCustomBitmap; const AllResolutions: Boolean = True);
procedure ReplaceIcon(AIndex: Integer; AIcon: TCustomIcon);
procedure ReplaceMasked(Index: Integer; NewImage: TCustomBitmap; MaskColor: TColor; const AllResolutions: Boolean = True);
procedure RegisterChanges(Value: TChangeLink);
procedure StretchDraw(Canvas: TCanvas; Index: Integer; ARect: TRect; Enabled: Boolean = True);
procedure UnRegisterChanges(Value: TChangeLink);
procedure RegisterResolutions(const AResolutionWidths: array of Integer); virtual;
procedure DeleteResolution(const AWidth: Integer);
function FindResolution(AImageWidth: Integer; out AResolution: TCustomImageListResolution): Boolean;
public
property AllocBy: Integer read FAllocBy write FAllocBy default 4;
property BlendColor: TColor read FBlendColor write FBlendColor default clNone;
property BkColor: TColor read FBkColor write SetBkColor default clNone;
property Count: Integer read GetCount;
property DrawingStyle: TDrawingStyle read FDrawingStyle write SetDrawingStyle default dsNormal;
property Height: Integer read FHeight write SetHeight default 16;
property HeightForPPI[AImageWidth, APPI: Integer]: Integer read GetHeightForPPI;
property HeightForWidth[AWidth: Integer]: Integer read GetHeightForWidth;
property Width: Integer read FWidth write SetWidth default 16;
property WidthForPPI[AImageWidth, APPI: Integer]: Integer read GetWidthForPPI;
property SizeForPPI[AImageWidth, APPI: Integer]: TSize read GetSizeForPPI;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property Masked: boolean read FMasked write SetMasked default False;
property Reference[AImageWidth: Integer]: TWSCustomImageListReference read GetReference;
property ReferenceForPPI[AImageWidth, APPI: Integer]: TWSCustomImageListReference read GetReferenceForPPI;
property Resolution[AImageWidth: Integer]: TCustomImageListResolution read GetResolution;
property ResolutionByIndex[AIndex: Integer]: TCustomImageListResolution read GetResolutionByIndex;
property ResolutionForPPI[AImageWidth, APPI: Integer; const ACanvasScaleFactor: Double]: TScaledImageListResolution read GetResolutionForPPI;
property ResolutionCount: Integer read GetResolutionCount;
function Resolutions: TCustomImageListResolutionEnumerator;
function ResolutionsDesc: TCustomImageListResolutionEnumerator;
property Scaled: Boolean read FScaled write FScaled default False;
property ShareImages: Boolean read FShareImages write SetShareImages default False;
property ImageType: TImageType read FImageType write FImageType default itImage;
property OnGetWidthForPPI: TCustomImageListGetWidthForPPI read FOnGetWidthForPPI write FOnGetWidthForPPI;
end;
TLCLGlyphsMissingResources = (
gmrAllMustExist, // Show exception if any image/resolution is not found
gmrOneMustExist, // Show exception if no resolution is found. Missing resolutions will be auto-generated from the biggest one.
gmrIgnoreAll); // Ignore all missing resources. No image will be added and TLCLGlyphs.GetImageIndex Result is -1 if no resolution is found.
TLCLGlyphs = class(TCustomImageList)
private type
TEntryKey = record
GlyphName: string;
end;
PEntryKey = ^TEntryKey;
TEntry = class
public
// key
GlyphName: string;
// value
ImageIndex: Integer; // the image index in TLCLGlyphs
end;
TResolution = record
Width: Integer;
ScaleSuffix: Integer;
end;
private
FMissingResources: TLCLGlyphsMissingResources;
FImageIndexes: TAvgLvlTree;
FLoadResolutions: array of TResolution;
FSuffix100Scale: Integer;
public
function GetImageIndex(const AResourceName: string): Integer;
// AResolutionWidths must be sorted from smallest to biggest
procedure RegisterResolutions(const AResolutionWidths: array of Integer); override;
procedure RegisterResolutions(const AResolutionWidths, AResolutionScaleSuffixes: array of Integer); overload;
procedure SetWidth100Suffix(const AWidth100Suffix: Integer);
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property MissingResources: TLCLGlyphsMissingResources read FMissingResources write FMissingResources;
end;
function LCLGlyphs: TLCLGlyphs;
function GetDefaultGlyph(ResourceName: string; ScalePercent: Integer = 100;
IgnoreMissingResource: Boolean = False): TCustomBitmap;
implementation
uses
WSImglist;
{$I imglist.inc}
end.
Reference in New Issue View Git Blame Copy Permalink