paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-22 07:22:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Step 1 of the native imagelist implementation

Browse Source 
git-svn-id: trunk@10875 -
This commit is contained in:
marc 2007-04-05 00:00:37 +00:00
parent 578459f760
commit b681f94950
18 changed files with 497 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
ide/buildlazdialog.pas
View File

@ -758,25 +758,23 @@ begin
ButtonRect, DFC_BUTTON, ButtonState);
// draw icon
case mm of
mmBuild: ImgIndex:=ImageIndexBuild;
mmCleanBuild: ImgIndex:=ImageIndexCleanBuild;
else ImgIndex:=ImageIndexNone;
mmBuild: ImgIndex:=ImageIndexBuild;
mmCleanBuild: ImgIndex:=ImageIndexCleanBuild;
else
ImgIndex:=ImageIndexNone;
end;
ImageList.GetInternalImage(ImgIndex,CurIcon,Mask,IconRect);
if CurIcon<>nil then begin
IconWidth:=IconRect.Right-IconRect.Left;
IconHeight:=IconRect.Bottom-IconRect.Top;
DestRect.Left:=ARect.Left+x+((ButtonWidth-IconWidth) div 2);
DestRect.Top:=ARect.Top+((ARect.Bottom-ARect.Top-IconHeight) div 2);
DestRect.Right:=DestRect.Left+IconWidth;
DestRect.Bottom:=DestRect.Top+IconHeight;
StretchMaskBlt(ItemsListBox.Canvas.Handle,
DestRect.Left, DestRect.Top, IconWidth, IconHeight,
CurIcon.Canvas.Handle, 0, 0, IconWidth, IconHeight,
CurIcon.MaskHandle, 0, 0, SRCCOPY);
end;
inc(x,ButtonWidth);
if ImgIndex <> ImageIndexNone
then
ImageList.Draw(
ItemsListBox.Canvas,
ARect.Left + x + ((ButtonWidth - ImageList.Width) div 2),
ARect.Top + ((ARect.Bottom - ARect.Top - ImageList.Height) div 2),
ImgIndex
) ;
Inc(x, ButtonWidth);
end;
// draw description
ItemsListBox.Canvas.Brush.Style:=bsClear;
ItemsListBox.Canvas.TextOut(x+2,

3
ide/codebrowser.pas
View File

@ -701,7 +701,8 @@ procedure TCodeBrowserView.InitImageList;
DebugLn('TCodeExplorerView.CodeExplorerViewCREATE: ',
' WARNING: icon not found: "',ResName,'"');
Pixmap.LoadFromLazarusResource(ResName);
ImgID:=ImgList.AddDirect(Pixmap,nil)
ImgID:=ImgList.Add(Pixmap,nil);
Pixmap.Free;
end;
begin

3
ide/codeexplorer.pas
View File

@ -210,7 +210,8 @@ procedure TCodeExplorerView.CodeExplorerViewCREATE(Sender: TObject);
DebugLn('TCodeExplorerView.CodeExplorerViewCREATE: ',
' WARNING: icon not found: "',ResName,'"');
Pixmap.LoadFromLazarusResource(ResName);
ImgID:=ImgList.AddDirect(Pixmap,nil)
ImgID:=ImgList.Add(Pixmap, nil);
Pixmap.Free;
end;
begin

3
ide/compileroptionsdlg.pp
View File

@ -322,7 +322,8 @@ constructor TfrmCompilerOptions.Create(TheOwner: TComponent);
Pixmap:=TPixmap.Create;
Pixmap.TransparentColor:=clWhite;
Pixmap.LoadFromLazarusResource(ResName);
ImageList.AddDirect(Pixmap,nil)
ImageList.Add(Pixmap,nil);
Pixmap.Free;
end;
var Page: integer;

3
ide/projectinspector.pas
View File

@ -419,7 +419,8 @@ procedure TProjectInspectorForm.SetupComponents;
Pixmap:=TPixmap.Create;
Pixmap.TransparentColor:=clWhite;
Pixmap.LoadFromLazarusResource(ResName);
ImageList.AddDirect(Pixmap,nil)
ImageList.Add(Pixmap,nil);
Pixmap.Free;
end;
begin

3
ide/sourcemarks.pas
View File

@ -685,7 +685,8 @@ begin
APixmap.TransparentColor:=clBtnFace;
APixmap.LoadFromLazarusResource(ResName);
Result:=ImgList.Count;
ImgList.AddDirect(APixmap,nil);
ImgList.Add(APixmap,nil);
APixmap.Free;
end;
function TSourceMarks.GetSourceEditor(AMark: TSourceMark): TObject;

8
ideintf/componenttreeview.pas
View File

@ -247,10 +247,10 @@ begin
FComponentList:=TBackupComponentList.Create;
Options:=Options+[tvoAllowMultiselect,tvoAutoItemHeight,tvoKeepCollapsedNodes];
FImageList := TImageList.Create(nil);
FImageList.AddFromLazarusResource('oi_form');
FImageList.AddFromLazarusResource('oi_comp');
FImageList.AddFromLazarusResource('oi_control');
FImageList.AddFromLazarusResource('oi_box');
FImageList.AddLazarusResource('oi_form');
FImageList.AddLazarusResource('oi_comp');
FImageList.AddLazarusResource('oi_control');
FImageList.AddLazarusResource('oi_box');
Images := FImageList;
end;

3
ideintf/imagelisteditor.pp
View File

@ -523,7 +523,8 @@ begin
Bmp := CreateGlyphSplit(v_CompositeBmp, ImageList.Width, ImageList.Height, c_Part);
Glyph := CreateGlyph(Bmp, ImageList.Width, ImageList.Height, gaNone);
I := ImageList.AddDirect(Glyph, nil);
I := ImageList.Add(Glyph, nil);
Glyph.Free;
New(P);
P^.Bitmap := Bmp;

2
lcl/graphics.pp
View File

@ -1169,8 +1169,8 @@ type
function PaletteAllocated: boolean;
procedure CreateFromBitmapHandles(SrcBitmap, SrcMaskBitmap: HBitmap;
const SrcRect: TRect);
procedure LoadFromDevice(DC: HDC); virtual;
function LazarusResourceTypeValid(const ResourceType: string): boolean; virtual;
procedure LoadFromDevice(DC: HDC); virtual;
procedure LoadFromStream(Stream: TStream); override;
procedure LoadFromLazarusResource(const ResName: String); override;
procedure LoadFromResourceName(Instance: THandle; const ResName: String); virtual;

76
lcl/imglist.pp
View File

@ -79,33 +79,52 @@ type
{ TCustomImageList }
{
@abstract(Contains a list of images)
Introduced by Marc Weustink <weus@quicknet.nl>
Introduced by Marc Weustink <marc@dommelstein.net>
ToDo:
Delphis TCustomImageList has internally only one bitmap to hold all
images. This reduces handle allocation, which is a problem under win9x,
but it is not very fast.
Because the LCL runs on many platforms, that do not have this limitations,
the TCustomImageList should also support a one handle per image mode.
The TCustomImageList should ask the interface, if handle allocation
should be reduced and if so do it like Delphi.
The current TCustomImageList is simply a list of bitmaps. The masks are
not saved at all yet.
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).
So a lot ToDo.
NOTE: due to its implementation, the TCustomImageList is not a TBitmap
collection. If a fast storage of bitmaps is needed, create your on list!
}
// Some temp rework defines, for old functionality both need so be set
{$define IMGLIST_OLDSTYLE} // Set to keep original functionality
{$define IMGLIST_KEEP_EXTRA} // Not needed for Delphi compat.
{$ifdef IMGLIST_OLDSTYLE}
// hack to set defines in dependent widgetsets.
TOldstyleCustomImageList = Boolean;
{$endif}
TDrawingStyle = (dsFocus, dsSelected, dsNormal, dsTransparent);
TImageType = (itImage, itMask);
TCustomImageList = Class(TLCLComponent)
TCustomImageList = class(TLCLHandleComponent)
private
FDrawingStyle: TDrawingStyle;
FData: array of TRGBAQuad;
{$ifdef IMGLIST_OLDSTYLE}
FHandle: THandle;
FImageList: TList;
FMaskList: TList;
{$endif}
{$ifdef IMGLIST_KEEP_EXTRA}
FBitmap: TBitmap;
FImageType: TImageType;
FMaskBitmap: TBitmap;
{$endif}
FImageType: TImageType;
FHeight: Integer;
FMasked: boolean;
FShareImages: Boolean;
@ -117,9 +136,14 @@ type
FOnChange: TNotifyEvent;
FChangeLinkList: TList;
FBkColor: TColor;
FHandle: THandle;
FChanged: boolean;
{$ifdef IMGLIST_OLDSTYLE}
procedure AllocBitmap(Amount: Integer);
{$else}
procedure AllocData(ACount: Integer);
{$endif}
procedure NotifyChangeLink;
procedure SetBkColor(const Value: TColor);
procedure SetDrawingStyle(const AValue: TDrawingStyle);
@ -131,12 +155,14 @@ type
procedure ShiftImages(const Source: TCanvas; Start, Shift: Integer);
protected
FUpdateCount: integer;
procedure CheckIndex(AIndex: Integer; AForInsert: Boolean = False);
procedure FillDescription(ADesc: TRawImageDescription);
procedure GetImages(Index: Integer; const Image, Mask: TBitmap);
procedure Initialize; virtual;
procedure DefineProperties(Filer: TFiler); override;
procedure SetWidthHeight(NewWidth,NewHeight: integer); virtual;
public
constructor Create(TheOwner: TComponent); override;
constructor Create(AOwner: TComponent); override;
procedure AssignTo(Dest: TPersistent); override;
procedure Assign(Source: TPersistent); override;
@ -146,24 +172,33 @@ type
procedure EndUpdate;
function Add(Image, Mask: TBitmap): Integer; // using AddCopy for Delphi compatibility
{$ifdef IMGLIST_OLDSTYLE}
function AddDirect(Image, Mask: TBitmap): Integer;
function AddCopy(SrcImage, SrcMask: TBitmap): Integer;
{$endif}
function AddIcon(Image: TIcon): Integer;
procedure AddImages(Value: TCustomImageList);
function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
function AddFromLazarusResource(const ResourceName: string): integer;
function AddLazarusResource(const ResourceName: string; MaskColor: TColor = clNone): integer;
procedure Change;
procedure Clear;
{.$ifdef IMGLIST_KEEP_EXTRA}
constructor CreateSize(AWidth, AHeight: Integer);
{.$endif}
procedure Delete(Index: Integer);
destructor Destroy; override;
procedure Draw(Canvas: TCanvas; X, Y, Index: Integer; Enabled: Boolean = True);
procedure GetBitmap(Index: Integer; Image: TBitmap);
{$ifdef IMGLIST_KEEP_EXTRA}
procedure GetInternalImage(Index: integer; var Image, Mask: TBitmap;
var ImageRect: TRect);
{$endif}
function GetHotSpot: TPoint; virtual;
procedure GetIcon(Index: Integer; Image: TIcon);
{$ifdef IMGLIST_OLDSTYLE}
function HandleAllocated: Boolean;
{$endif}
procedure Insert(Index: Integer; Image, Mask: TBitmap);
procedure InsertIcon(Index: Integer; Image: TIcon);
procedure InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
@ -172,6 +207,7 @@ type
procedure ReplaceIcon(Index: Integer; Image: TIcon);
procedure ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor);
procedure RegisterChanges(Value: TChangeLink);
procedure StretchDraw(Canvas: TCanvas; Index: Integer; ARect: TRect; Enabled: Boolean = True);
procedure UnRegisterChanges(Value: TChangeLink);
public
property AllocBy: Integer read FAllocBy write FAllocBy default 4;
@ -179,13 +215,17 @@ type
property BkColor: TColor read FBkColor write SetBkColor default clNone;
property Count: Integer read FCount;
property DrawingStyle: TDrawingStyle read FDrawingStyle write SetDrawingStyle default dsNormal;
{$ifdef IMGLIST_OLDSTYLE}
property Handle: THandle read FHandle;
{$endif}
property Height: Integer read FHeight write SetHeight default 16;
property Width: Integer read FWidth write SetWidth default 16;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property Masked: boolean read FMasked write SetMasked;
{$ifdef IMGLIST_KEEP_EXTRA}
property Bitmap: TBitmap read FBitmap;
property MaskBitmap: TBitmap read FMaskBitmap;
{$endif}
property ShareImages: Boolean read FShareImages write SetShareImages;
property ImageType: TImageType read FImageType write FImageType default itImage;
end;

414
lcl/include/imglist.inc
View File

@ -24,6 +24,7 @@ type
const
SIG_LAZ1 = #1#0;
SIG_LAZ2 = 'li';
SIG_LAZ3 = 'Li';
SIG_D3 = 'IL';
{------------------------------------------------------------------------------
@ -61,9 +62,15 @@ end;
------------------------------------------------------------------------------}
function TCustomImageList.Add(Image, Mask: TBitmap): Integer;
begin
{$ifdef IMGLIST_OLDSTYLE}
Result:=AddCopy(Image,Mask);
{$else}
Result := Count;
Insert(Result, Image, Mask);
{$endif}
end;
{$ifdef IMGLIST_OLDSTYLE}
function TCustomImageList.AddDirect(Image, Mask: TBitmap): Integer;
begin
try
@ -76,7 +83,9 @@ begin
end;
end;
end;
{$endif}
{$ifdef IMGLIST_OLDSTYLE}
function TCustomImageList.AddCopy(SrcImage, SrcMask: TBitmap): Integer;
var
NewImage: TBitmap;
@ -100,6 +109,7 @@ begin
NewMask.Free;
end;
end;
{$endif}
{------------------------------------------------------------------------------
Function: TCustomImageList.AddIcon
@ -133,6 +143,8 @@ var
NewMask: TBitmap;
begin
if (Value = nil) or (Value=Self) then exit;
{$ifdef IMGLIST_OLDSTYLE}
BeginUpdate;
for n := 0 to Value.Count - 1 do begin
SrcImage:=TBitmap(Value.FImageList[n]);
@ -149,6 +161,9 @@ begin
end;
end;
EndUpdate;
{$else}
{$note implement}
{$endif}
end;
{------------------------------------------------------------------------------
@ -179,14 +194,21 @@ end;
Load TBitmap from lazarus resources and add it.
------------------------------------------------------------------------------}
function TCustomImageList.AddFromLazarusResource(const ResourceName: string
): integer;
function TCustomImageList.AddLazarusResource(const ResourceName: string; MaskColor: TColor): integer;
var
ABitmap: TBitmap;
Bmp: TBitmap;
begin
ABitmap:=TBitmap.Create;
ABitmap.LoadFromLazarusResource(ResourceName);
Result:=AddDirect(ABitmap,nil);
Bmp := TBitmap.Create;
Bmp.LoadFromLazarusResource(ResourceName);
if MaskColor <> clNone then
Bmp.TransparentColor := MaskColor;
{$ifdef IMGLIST_OLDSTYLE}
Result := AddDirect(Bmp, nil);
{$else}
Result := Add(Bmp, nil);
Bmp.Free;
{$endif}
end;
{------------------------------------------------------------------------------
@ -197,27 +219,46 @@ end;
Checks if there is enough space for Amount images, increases the internal
list if necessary .
------------------------------------------------------------------------------}
{$ifdef IMGLIST_OLDSTYLE}
procedure TCustomImageList.AllocBitmap(Amount: Integer);
var
Num: Integer;
n: Integer;
begin
Assert(FAllocCount >= FCount, 'Less space allocated than images');
if FAllocCount < FCount + Amount
then begin
// calculate number of blocks
Num := Amount div FAllocBy;
// add an extra block for the remainder.
if Amount mod FAllocBy <> 0 then Inc(Num);
if FAllocCount >= FCount + Amount
then Exit;
if FBitMap<>nil then
FBitMap.Height := FBitMap.Height + Num * FAllocBy * FHeight;
if FMaskBitmap<>nil then
FMaskBitmap.Height := FBitMap.Height;
Inc(FAllocCount, Num * FAllocBy);
end;
// calculate number of blocks, add an extra block for the remainder.
n := Amount mod FAllocBy;
if n <> 0
then Inc(Amount, FAllocBy - n);
//raise Exception.Create('Unable to allocate bitmap space');
if FBitMap<>nil then
FBitMap.Height := FBitMap.Height + Amount * FHeight;
if FMaskBitmap<>nil then
FMaskBitmap.Height := FBitMap.Height;
Inc(FAllocCount, Amount);
end;
{$else}
procedure TCustomImageList.AllocData(ACount: Integer);
var
n: Integer;
begin
Assert(FAllocCount >= FCount, 'Less space allocated than images');
if FAllocCount >= FCount + ACount
then Exit;
// calculate number of blocks, add an extra block for the remainder.
n := ACount mod FAllocBy;
if n <> 0
then Inc(ACount, FAllocBy - n);
SetLength(FData, ACount * FWidth * FHeight * SizeOf(FData[0]));
Inc(FAllocCount, ACount);
end;
{$endif}
{------------------------------------------------------------------------------
Method: TCustomImageList.Assign
@ -283,6 +324,22 @@ begin
FChanged := false;
end;
procedure TCustomImageList.CheckIndex(AIndex: Integer; AForInsert: Boolean);
// aviod exceptionframe generation
procedure Error;
begin
raise EInvalidOperation.Create(SInvalidIndex);
end;
begin
if AForInsert
then begin
if AIndex > FCount then Error;
end
else begin
if AIndex >= FCount then Error;
end;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Clear
Params: None
@ -292,12 +349,17 @@ end;
------------------------------------------------------------------------------}
procedure TCustomImageList.Clear;
begin
if FCount=0 then exit;
While Count>0 do
if FCount = 0 then Exit;
{$ifdef IMGLIST_OLDSTYLE}
while Count>0 do
Delete(0);
FCount := 0;
FImageList.Clear;
FMaskList.Clear;
{$else}
{$note implement}
{$endif}
FCount := 0;
Change;
end;
@ -308,13 +370,16 @@ end;
Constructor for the class.
------------------------------------------------------------------------------}
constructor TCustomImageList.Create(TheOwner: TComponent);
constructor TCustomImageList.Create(AOwner: TComponent);
begin
inherited Create(TheOwner);
inherited Create(AOwner);
FHeight := 16;
FWidth := 16;
{$ifdef IMGLIST_OLDSTYLE}
FImageList := TList.Create; //shane
FMaskList := TList.Create;
{$endif}
Initialize;
end;
@ -326,15 +391,20 @@ end;
Runtime constructor for the class with a given width and height.
------------------------------------------------------------------------------}
{.$ifdef IMGLIST_KEEP_EXTRA}
constructor TCustomImageList.CreateSize(AWidth, AHeight: Integer);
begin
inherited Create(nil);
FHeight := AHeight;
FWidth := AWidth;
{$ifdef IMGLIST_OLDSTYLE}
FImageList := TList.Create; //shane
FMaskList := TList.Create;
{$endif}
Initialize;
end;
{.$endif}
{------------------------------------------------------------------------------
Method: TCustomImageList.DefineProperties
@ -379,6 +449,7 @@ begin
Clear
else
begin
{$ifdef IMGLIST_OLDSTYLE}
Obj:=TObject(fImageList.Items[Index]);
If Assigned(Obj) then
Obj.Free;
@ -390,6 +461,9 @@ begin
// ShiftImages(FBitmap.Canvas, Index, 1);
// ShiftImages(FMaskBitmap.Canvas, Index, 1);
FCount := fImageList.Count;
{$else}
{$note implement}
{$endif}
FChanged := true;
Change;
end;
@ -406,6 +480,7 @@ destructor TCustomImageList.Destroy;
var
i: integer;
begin
{$ifdef IMGLIST_OLDSTYLE}
FBitmap.Free;
FBitmap:=nil;
FMaskBitmap.Free;
@ -414,6 +489,7 @@ begin
for i:=0 to FMaskList.Count-1 do TObject(FMaskList[i]).Free;
FreeThenNil(FImageList);
FreeThenNil(FMaskList);
{$endif}
inherited Destroy;
while FChangeLinkList.Count>0 do
UnregisterChanges(TChangeLink(FChangeLinkList[0]));
@ -437,8 +513,13 @@ var
aBitmap: TBitmap;
begin
if (FCount = 0) or (Index >= FCount) then Exit;
{$ifdef IMGLIST_OLDSTYLE}
aBitmap := TBitmap(FImageList[Index]);
Canvas.Draw(X,Y,aBitmap);
{$else}
{$note implement}
{$endif}
end;
{------------------------------------------------------------------------------
@ -456,6 +537,36 @@ begin
Change;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.FillDescription
Params: Desc: the description to fill
Returns: Nothing
Fills the description with the default info of the imagedata
------------------------------------------------------------------------------}
procedure TCustomImageList.FillDescription(ADesc: TRawImageDescription);
begin
ADesc.Format := ricfRGBA;
ADesc.HasPalette := False;
ADesc.Depth := 32;
ADesc.Width := FWidth;
ADesc.Height := FHeight;
ADesc.BitOrder := riboBitsInOrder;
ADesc.ByteOrder := riboMSBFirst;
ADesc.LineOrder := riloTopToBottom;
ADesc.BitsPerPixel := 32;
ADesc.LineEnd := rileDWordBoundary;
ADesc.RedPrec := 8; // red precision. bits for red
ADesc.RedShift := 24;
ADesc.GreenPrec := 8;
ADesc.GreenShift := 16;
ADesc.BluePrec := 8;
ADesc.BlueShift := 8;
ADesc.AlphaPrec := 8;
ADesc.AlphaShift := 0;
ADesc.AlphaSeparate := False;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.GetBitmap
Params: Index: the index of the requested image
@ -465,10 +576,27 @@ end;
Creates a copy of the index'th image.
------------------------------------------------------------------------------}
procedure TCustomImageList.GetBitmap(Index: Integer; Image: TBitmap);
{$ifndef IMGLIST_OLDSTYLE}
var
RawImg: TRawImage;
IntfImg: TLazIntfImage;
{$endif}
begin
if (FCount = 0) or (Image = nil) then Exit;
//DebugLn('TCustomImageList.GetBitmap Index=',Index,' Image=',DbgS(Image),' Bitmap=',DbgS(FImageList.Items[Index]));
{$ifdef IMGLIST_OLDSTYLE}
Image.Assign(TBitMap(FImageList.Items[Index]));
{$else}
CheckIndex(Index);
FillChar(RawImg, SizeOf(RawImg), 0);
FillDescription(RawImg.Description);
RawImg.DataSize := FWidth * FHeight;
RawImg.Data := @FData[Index * RawImg.DataSize];
IntfImg := TLazIntfImage.Create(RawImg);
Image.LoadFromIntfImage(IntfImg);
IntfImg.Free;
{$endif}
end;
{------------------------------------------------------------------------------
@ -479,6 +607,7 @@ end;
images into one bitmap (plus one mask), therefore ImageRect contains the
bounds of the n-th image on the bitmap.
------------------------------------------------------------------------------}
{$ifdef IMGLIST_KEEP_EXTRA}
procedure TCustomImageList.GetInternalImage(Index: integer; var Image,
Mask: TBitmap; var ImageRect: TRect);
begin
@ -486,6 +615,7 @@ begin
Mask:=TBitmap(FMaskList[Index]);
ImageRect:=Rect(0,0,Image.Width,Image.Height);
end;
{$endif}
{------------------------------------------------------------------------------
Function: TCustomImageList.GetHotspot
@ -527,6 +657,7 @@ end;
------------------------------------------------------------------------------}
procedure TCustomImageList.GetImages(Index: Integer; const Image, Mask: TBitmap);
begin
{$ifdef IMGLIST_OLDSTYLE}
with Image do FBitmap.Canvas.CopyRect(
Rect(0, 0, Width, Height),
Canvas,
@ -537,6 +668,9 @@ begin
Canvas,
Rect(0, Index * FHeight, FWidth, (Index + 1) * FHeight)
);
{$else}
{$note implement}
{$endif}
end;
{------------------------------------------------------------------------------
@ -546,10 +680,12 @@ end;
This function checks if the internal image is allocated
------------------------------------------------------------------------------}
{$ifdef IMGLIST_OLDSTYLE}
function TCustomImageList.HandleAllocated: Boolean;
begin
Result := (FBitmap <> nil);
end;
{$endif}
{------------------------------------------------------------------------------
Method: TCustomImageList.Initialize
@ -570,6 +706,7 @@ begin
if (Height < 1) or (Height > 32768) or (Width < 1)
then raise EInvalidOperation.Create(SInvalidImageSize);
{$ifdef IMGLIST_OLDSTYLE}
FBitmap := TBitmap.Create;
FBitmap.Height := Height;
FBitmap.Width := Width;
@ -581,6 +718,7 @@ begin
Canvas.Brush.Color := clWhite;
Monochrome := True;
end;
{$endif}
end;
procedure TCustomImageList.SetWidthHeight(NewWidth, NewHeight: integer);
@ -588,9 +726,11 @@ begin
if (FHeight=NewHeight) and (FWidth=NewWidth) then exit;
FHeight := NewHeight;
FWidth := NewWidth;
{$ifdef IMGLIST_OLDSTYLE}
FBitMap.Width := 0;
FBitMap.Height := 0;
AllocBitmap(0);
{$endif}
Clear;
end;
@ -606,11 +746,11 @@ end;
------------------------------------------------------------------------------}
procedure TCustomImageList.Insert(Index: Integer; Image, Mask: TBitmap);
begin
if (Index > Count)
then raise EInvalidOperation.Create(SInvalidIndex);
CheckIndex(Index, True);
if (Index < 0) then Index := 0;
{$ifdef IMGLIST_OLDSTYLE}
if (Image <> nil)
then begin
FImageList.Insert(Index,Image);
@ -619,6 +759,10 @@ begin
FChanged := true;
Change;
end;
{$else}
{$note Implement}
{$endif}
end;
{------------------------------------------------------------------------------
@ -631,13 +775,14 @@ end;
------------------------------------------------------------------------------}
procedure TCustomImageList.InsertIcon(Index: Integer; Image: TIcon);
begin
if (Index > FCount)
then raise EInvalidOperation.Create(SInvalidIndex);
CheckIndex(Index, True);
if (Index < 0) then Index := 0;
//No Icon Support yet
{$ifndef IMGLIST_OLDSTYLE}
{$note implement}
{$endif}
end;
{------------------------------------------------------------------------------
@ -664,6 +809,9 @@ begin
Mask(MaskColor);
end;
Insert(Index, Image, Mask);
{$ifndef IMGLIST_OLDSTYLE}
Mask.Free;
{$endif}
end;
{------------------------------------------------------------------------------
@ -675,13 +823,40 @@ end;
Moves an image from the CurIndex'th location to NewIndex'th location
------------------------------------------------------------------------------}
procedure TCustomImageList.Move(CurIndex, NewIndex: Integer);
{$ifndef IMGLIST_OLDSTYLE}
var
ImgSize, DataSize: Cardinal;
p: Pointer;
{$endif}
begin
if CurIndex <> NewIndex then begin
FImageList.Move(CurIndex,NewIndex);
FMaskList.Move(CurIndex,NewIndex);
FChanged := true;
Change;
end;
if CurIndex = NewIndex then Exit;
CheckIndex(CurIndex);
CheckIndex(NewIndex);
if CurIndex < 0 then CurIndex := 0;
if NewIndex < 0 then NewIndex := 0;
{$ifdef IMGLIST_OLDSTYLE}
FImageList.Move(CurIndex,NewIndex);
FMaskList.Move(CurIndex,NewIndex);
{$else}
ImgSize := FWidth * FHeight;
DataSize := ImgSize * SizeOf(FData[0]);
p := GetMem(DataSize);
// store current
System.Move(FData[Cardinal(CurIndex) * ImgSize], p^, DataSize);
// move all one up
if CurIndex < NewIndex
then System.Move(FData[(Cardinal(CurIndex) + 1) * ImgSize], FData[Cardinal(CurIndex) * ImgSize], DataSize * Cardinal(NewIndex - CurIndex))
else System.Move(FData[Cardinal(NewIndex) * ImgSize], FData[(Cardinal(NewIndex) + 1) * ImgSize], DataSize * Cardinal(NewIndex - CurIndex));
// restore current
System.Move(p^, FData[Cardinal(NewIndex) * ImgSize], DataSize);
FreeMem(p);
{$endif}
FChanged := true;
Change;
end;
{------------------------------------------------------------------------------
@ -715,7 +890,11 @@ var
Signature: TImageListSignature;
begin
//Write signature
{$ifdef IMGLIST_OLDSTYLE}
Signature:=SIG_LAZ2;
{$else}
Signature:=SIG_LAZ3;
{$endif}
AStream.Write(Signature,SizeOf(Signature));
//Count of image
@ -723,12 +902,17 @@ begin
WriteLRSInteger(AStream,Width);
WriteLRSInteger(AStream,Height);
//images
{$ifdef IMGLIST_OLDSTYLE}
for i:=0 to Count-1 do
begin
CurImage:=TBitmap(FImageList[i]);
//DebugLn('TCustomImageList.WriteData Position=',AStream.Position,' ',CurImage.Width,',',CurImage.Height);
CurImage.WriteNativeStream(AStream,true,bnXPixmap);
end;
{$else}
AStream.Write(FData[0], FWidth * FHeight * FCount * SizeOf(FData[0]));
{$endif}
end;
{------------------------------------------------------------------------------
@ -748,17 +932,20 @@ var
i, NewCount, Size: Integer;
bmp: TBitmap;
begin
//DebugLn('TCustomImageList.ReadData DoReadLaz1');
// provided for compatability for earlier lazarus streams
NewCount := AStream.ReadWord;
//DebugLn('TCustomImageList.ReadData DoReadLaz1 NewCount=',NewCount);
for i := 0 to NewCount - 1 do
begin
bmp := TBitMap.Create;
Size:=ReadLRSInteger(AStream);
bmp.ReadStream(AStream, True, Size);
bmp.Transparent := True;
{$ifdef IMGLIST_OLDSTYLE}
AddDirect(bmp, nil);
{$else}
Add(bmp, nil);
bmp.Free;
{$endif}
end;
end;
@ -779,9 +966,31 @@ var
Size:=ReadLRSCardinal(AStream);
//DebugLn('TCustomImageList.ReadData DoReadLaz2 Size=',Size,' ',AStream.Position);
bmp.ReadStream(AStream, True, Size);
{$ifdef IMGLIST_OLDSTYLE}
AddDirect(bmp, nil);
{$else}
Add(bmp, nil);
bmp.Free;
{$endif}
end;
end;
procedure DoReadLaz3;
begin
FCount := ReadLRSCardinal(AStream);
FWidth := ReadLRSCardinal(AStream);
FHeight := ReadLRSCardinal(AStream);
{$ifdef IMGLIST_OLDSTYLE}
AStream.Seek(FWidth * FHeight * FCount * 4, soCurrent);
{$else}
AllocData(FCount);
AStream.ReadBuffer(FData[0], FWidth * FHeight * FCount * SizeOf(FData[0])) ;
{$endif}
FChanged := true;
Change;
end;
procedure CreateImagesFromRawImage(IntfImage: TLazIntfImage;
NewCount: integer);
@ -817,7 +1026,12 @@ var
Img.Handle:=ImgHandle;
Img.MaskHandle:=MaskHandle;
{$ifdef IMGLIST_OLDSTYLE}
AddDirect(Img, nil);
{$else}
Add(Img, nil);
Img.Free;
{$endif}
//DebugLn('CreateImagesFromRawImage B ',Img.Width,',',Img.Height,' ',Count);
Img := nil;
Dec(NewCount);
@ -887,55 +1101,67 @@ var
NewCount: Integer;
Size: integer;
begin
Clear;
BeginUpdate; // avoid multiple changed calls
try
Clear;
StreamPos := AStream.Position; // check stream signature
AStream.Read(Signature, SizeOf(Signature));
StreamPos := AStream.Position; // check stream signature
AStream.Read(Signature, SizeOf(Signature));
if Signature = SIG_LAZ1
then begin
DoReadLaz1;
Exit;
end;
if Signature = SIG_LAZ3
then begin
DoReadLaz3;
Exit;
end;
if Signature = SIG_LAZ2
then begin
DoReadLaz2;
Exit;
end;
if Signature = SIG_LAZ2
then begin
DoReadLaz2;
Exit;
end;
// Delphi streams
if Signature = SIG_LAZ1
then begin
DoReadLaz1;
Exit;
end;
{$IFDEF SaveDelphiImgListStream}
SaveImgListStreamToFile;
{$ENDIF}
// Delphi streams
if Signature = SIG_D3
then begin
AStream.ReadWord; //Skip ?
NewCount := ReadLRSWord(AStream);
//DebugLn('NewCount=',NewCount);
AStream.ReadWord; //Skip Capacity
AStream.ReadWord; //Skip Grow
FWidth := ReadLRSWord(AStream);
//DebugLn('NewWidth=',FWidth);
FHeight := ReadLRSWord(AStream);
//DebugLn('NewHeight=',FHeight);
FBKColor := TColor(ReadLRSInteger(AStream));
HasMask := (ReadLRSWord(AStream) and 1) = 1;
AStream.ReadDWord; //Skip ?
AStream.ReadDWord; //Skip ?
{$IFDEF SaveDelphiImgListStream}
SaveImgListStreamToFile;
{$ENDIF}
ReadDelphiImageAndMask(HasMask,NewCount);
end
else begin
// D2 has no signature, so restore original position
AStream.Position := StreamPos;
Size:=ReadLRSInteger(AStream);
NewCount:=ReadLRSInteger(AStream);
if Signature = SIG_D3
then begin
AStream.ReadWord; //Skip ?
NewCount := ReadLRSWord(AStream);
//DebugLn('NewCount=',NewCount);
AStream.ReadWord; //Skip Capacity
AStream.ReadWord; //Skip Grow
FWidth := ReadLRSWord(AStream);
//DebugLn('NewWidth=',FWidth);
FHeight := ReadLRSWord(AStream);
//DebugLn('NewHeight=',FHeight);
FBKColor := TColor(ReadLRSInteger(AStream));
HasMask := (ReadLRSWord(AStream) and 1) = 1;
AStream.ReadDWord; //Skip ?
AStream.ReadDWord; //Skip ?
ReadDelphiImageAndMask(false,NewCount);
AStream.Position := StreamPos+Size;
ReadDelphiImageAndMask(HasMask,NewCount);
end
else begin
// D2 has no signature, so restore original position
AStream.Position := StreamPos;
Size:=ReadLRSInteger(AStream);
NewCount:=ReadLRSInteger(AStream);
ReadDelphiImageAndMask(false,NewCount);
AStream.Position := StreamPos+Size;
end;
finally
EndUpdate;
end;
end;
@ -977,17 +1203,21 @@ begin
DestinationRect := Rect(0, Index * FHeight, FWidth, (Index + 1) * FHeight);
SourceRect := Rect(0, 0, FWidth, FHeight);
{$ifdef IMGLIST_OLDSTYLE}
CopyImage(FBitmap.Canvas, Image.Canvas, DestinationRect, SourceRect);
if Mask <> nil
then CopyImage(FMaskBitmap.Canvas, Mask.Canvas, DestinationRect, SourceRect)
else FMaskBitmap.Canvas.FillRect(DestinationRect);
{$else}
{$note implement}
{$endif}
FChanged := true;
Change;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Replace
Method: TCustomImageList.ReplaceIcon
Params: Index: the index of the replaceded image
Image: an icon image
Returns: Nothing.
@ -1002,6 +1232,9 @@ begin
if (Index < 0) then Index := 0;
// No Icon suppport yet
{$ifndef IMGLIST_OLDSTYLE}
{$note implement}
{$endif}
end;
{------------------------------------------------------------------------------
@ -1021,6 +1254,9 @@ begin
if (Index < 0) then Index := 0;
{$ifndef IMGLIST_OLDSTYLE}
{$note implement}
{$endif}
end;
{------------------------------------------------------------------------------
@ -1120,6 +1356,22 @@ begin
end;
end;
procedure TCustomImageList.StretchDraw(Canvas: TCanvas; Index: Integer; ARect: TRect; Enabled: Boolean);
var
bmp, msk: TBitmap;
begin
if (FCount = 0) or (Index >= FCount) then Exit;
{$ifdef IMGLIST_OLDSTYLE}
bmp := TBitmap(FImageList[Index]);
msk := TBitmap(FMaskList[Index]);
StretchMaskBlt(Canvas.Handle, ARect.Left, ARect.Top, ARect.Right - ARect.Left,
ARect.Bottom - ARect.Top, bmp.Handle, 0, 0, FWidth, FHeight, msk.Handle, 0, 0, SRCCOPY);
{$else}
{$note implement}
{$endif}
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.UnRegisterChanges
Params: Value: a reference to changelink object

4
lcl/interfaces/gtk/gtkpagecallback.inc
View File

@ -35,7 +35,11 @@ begin
TabWidget:=gtk_notebook_get_tab_label(PGtkNoteBook(NotebookWidget),
PageWidget);
if TabWidget=nil then exit;
{$ifdef IMGLIST_OLDSTYLE}
DrawImageListIconOnWidget(NoteBook.Images,Page.ImageIndex,Widget);
{$else}
{$note implement}
{$endif}
end;
function PageIconWidgetExposeAfter(Widget: PGtkWidget; Event: PGDKEventExpose;

12
lcl/interfaces/gtk/gtkproc.inc
View File

@ -1289,12 +1289,17 @@ begin
{$EndIf}
end;
{$ifdef IMGLIST_OLDSTYLE}
procedure DrawImageListIconOnWidget(ImgList: TCustomImageList;
Index: integer; DestWidget: PGTKWidget);
begin
DrawImageListIconOnWidget(ImgList,Index,DestWidget,true,true,0,0);
end;
{$else}
{$note TODO: Remove me}
{$endif}
{$ifdef IMGLIST_OLDSTYLE}
procedure DrawImageListIconOnWidget(ImgList: TCustomImageList;
Index: integer; DestWidget: PGTKWidget;
CenterHorizontally, CenterVertically: boolean;
@ -1335,6 +1340,9 @@ begin
SRCCOPY);
ReleaseDC(HDC(DestWidget),DestDC);
end;
{$else}
{$note TODO: Remove me}
{$endif}
function GetPGdkImageBitsPerPixel(Image: PGdkImage): cardinal;
begin
@ -5704,8 +5712,12 @@ begin
IconImg,0,0,ALeft,ATop,-1,-1);
gdk_gc_set_clip_mask(gtk_widget_get_style(Widget)^.Black_gc, nil);
end else begin
{$ifdef IMGLIST_OLDSTYLE}
DrawImageListIconOnWidget(LCLMenuItem.GetImageList,LCLMenuItem.ImageIndex,
Widget,false,false,ALeft,ATop);
{$else}
{$note Implement}
{$endif}
end;
end;

15
lcl/interfaces/gtk/gtkproc.pp
View File

@ -49,11 +49,20 @@ uses
FileUtil, ImgList, GtkFontCache, GTKGlobals, gtkDef, GtkExtra;
const
GtkListItemGtkListTag = 'GtkList';
GtkListItemLCLListTag = 'LCLList';
{$if Declared(TOldStyleCustomImageList)}
{$define IMGLIST_OLDSTYLE}
{$else}
{$note TODO: remove me}
{$endif}
type
PPWaitHandleEventHandler = ^PWaitHandleEventHandler;
PWaitHandleEventHandler = ^TWaitHandleEventHandler;
@ -646,12 +655,16 @@ function ScalePixmap(ScaleGC: PGDKGC;
SrcColorMap: PGdkColormap;
NewWidth, NewHeight: integer;
var NewPixmap: PGdkPixmap): Boolean;
{$ifdef IMGLIST_OLDSTYLE}
procedure DrawImageListIconOnWidget(ImgList: TCustomImageList;
Index: integer; DestWidget: PGTKWidget);
procedure DrawImageListIconOnWidget(ImgList: TCustomImageList;
Index: integer; DestWidget: PGTKWidget;
CenterHorizontally, CenterVertically: boolean;
DestLeft, DestTop: integer);
{$else}
{$note TODO: Remove me}
{$endif}
function GetPGdkImageBitsPerPixel(Image: PGdkImage): cardinal;
function CreateGdkBitmap(Window: PGdkWindow; Width, Height: integer): PGdkBitmap;
function ExtractGdkBitmap(Bitmap: PGdkBitmap; const SrcRect: TRect): PGdkBitmap;

5
lcl/interfaces/gtk/gtkwscomctrls.pp
View File

@ -42,6 +42,11 @@ uses
GtkDef, GtkExtra, GtkWSPrivate;
type
{$if Declared(TOldStyleCustomImageList)}
{$define IMGLIST_OLDSTYLE}
{$else}
{$note TODO: remove me}
{$endif}
{ TGtkWSStatusBar }

10
lcl/interfaces/gtk/gtkwscustomlistview.inc
View File

@ -501,6 +501,7 @@ begin
and (AItem.ImageIndex < TLVHack(ALV).SmallImages.Count)
then begin
// set image & caption
{$ifdef IMGLIST_OLDSTYLE}
TLVHack(ALV).SmallImages.GetInternalImage(AItem.ImageIndex, ImageBitmap, MaskBitmap, ImageRect);
if (ImageRect.Left <> 0)
or (ImageRect.Top <> 0)
@ -508,6 +509,9 @@ begin
Pixmap := PGDIObject(ImageBitmap.Handle)^.GDIPixmapObject;
Mask := PGdkBitmap(PGDIObject(ImageBitmap.Handle)^.GDIBitmapMaskObject);
gtk_clist_set_pixtext(ACListWidget, AIndex, 0, PChar(AItem.Caption), 3, Pixmap, Mask);
{$else}
{$note implement}
{$endif}
end
else begin
// set caption alone
@ -634,6 +638,7 @@ begin
WidgetInfo := GetWidgetInfo(Pointer(ALV.Handle));
CListWidget := PGtkCList(WidgetInfo^.CoreWidget);
{$ifdef IMGLIST_OLDSTYLE}
if (TLVHack(ALV).SmallImages <> nil)
and (AImageIndex >= 0)
and (AImageIndex < TLVHack(ALV).SmallImages.Count)
@ -650,6 +655,11 @@ begin
Pixmap := nil;
Mask := nil;
end;
{$else}
{$note implement}
Pixmap := nil;
Mask := nil;
{$endif}
CellType := gtk_clist_get_cell_type(CListWidget, AIndex, ASubIndex);
// Sigh.

20
lcl/intfgraphics.pas
View File

@ -173,6 +173,7 @@ type
procedure SetColor_BPP32_R8G8B8_A1_BIO_TTB_RBO(x, y: integer; const Value: TFPColor);
public
constructor Create(AWidth, AHeight: integer); override;
constructor Create(ARawImage: TRawImage);
destructor Destroy; override;
procedure BeginUpdate;
procedure EndUpdate;
@ -1635,6 +1636,25 @@ begin
inherited Create(AWidth, AHeight);
end;
constructor TLazIntfImage.Create(ARawImage: TRawImage);
begin
Create(FDataDescription.Width, FDataDescription.Height);
FDataDescription := ARawImage.Description;
FPixelData := ARawImage.Data;
FPixelDataSize := ARawImage.DataSize;
FMaskData := ARawImage.Mask;
FMaskDataSize := ARawImage.MaskSize;
FCreateAllDataNeeded := False;
CreateRawImageLineStarts(Width, Height, FDataDescription.BitsPerPixel,
FDataDescription.LineEnd, FLineStarts);
if FMaskData <> nil
then CreateRawImageLineStarts(Width, Height, FDataDescription.AlphaBitsPerPixel,
FDataDescription.AlphaLineEnd, FMaskLineStarts);
ChooseGetSetColorFunctions;
end;
destructor TLazIntfImage.Destroy;
begin
FreeAllData;

9
lcl/lcltype.pp
View File

@ -1053,6 +1053,15 @@ type
end;
TRGBQuad = tagRGBQUAD;
RGBQUAD = tagRGBQUAD;
TRGBAQuad = record
Blue: Byte;
Green: Byte;
Red: Byte;
Alpha: Byte;
end;
PRGBAQuad = ^TRGBAQuad;
PBitmapInfo = ^TBitmapInfo;
tagBITMAPINFO = record