paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-03 22:18:16 +02:00
Code Issues Packages Projects Releases Wiki Activity
94d066eea6
lazarus/lcl/include/imglist.inc
mattias 94d066eea6 clean up for TBitmapImage sharing 
git-svn-id: trunk@5252 -
2004-03-02 22:37:36 +00:00

1283 lines
39 KiB
PHP
Raw Blame History

// included by imglist.pp
{******************************************************************************
TCustomImageList
******************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
const
SIG_LAZ1 = #1#0;
SIG_LAZ2 = 'li';
SIG_D3 = 'IL';
{------------------------------------------------------------------------------
Method: CopyImage
Params: Destination, Source: the destination/source canvas
DestinationRect: the rectangle where the image is copied to
SourceRect: the rectangle containing the part to be copied
Returns: Nothing
Internal routine to copy a rectangle from a source canvas to a rectangle on
the destination canvas
------------------------------------------------------------------------------}
procedure CopyImage(Destination, Source: TCanvas; DestinationRect, SourceRect: TRect);
begin
Destination.CopyRect(
DestinationRect,
Source,
SourceRect
);
end;
{ TCustomImageList }
{------------------------------------------------------------------------------
Function: TCustomImageList.Add
Params: Image: a bitmap image
Mask: a bitmap which defines the transparent parts of Image
Returns: The index of the added image, -1 if unsuccesfull.
Adds one or more (bitmap width / imagelist width) bitmaps to the list.
If Mask is nil, the image has no transparent parts.
------------------------------------------------------------------------------}
function TCustomImageList.Add(Image, Mask: TBitmap): Integer;
begin
Result:=AddDirect(Image,Mask);
end;
function TCustomImageList.AddDirect(Image, Mask: TBitmap): Integer;
begin
try
Result := Count;
Insert(Result, Image, Mask);
Change;
except
on E: Exception do begin
writeln('TCustomImageList.Add ',E.Message);
Result := -1; // Ignore exceptions, just return -1
end;
end;
end;
function TCustomImageList.AddCopy(SrcImage, SrcMask: TBitmap): Integer;
var
NewImage: TBitmap;
NewMask: TBitmap;
begin
NewImage:=nil;
NewMask:=nil;
try
NewImage := TBitmap.Create;
NewImage.Assign(SrcImage);
if Assigned(SrcMask)
then begin
NewMask := TBitmap.Create;
NewMask.Assign(SrcMask);
end;
Result:=AddDirect(NewImage, NewMask);
NewImage:=nil;
NewMask:=nil;
finally
NewImage.Free;
NewMask.Free;
end;
end;
{------------------------------------------------------------------------------
Function: TCustomImageList.AddIcon
Params: Image: the Icon to be added;
Returns: The index of the added icon, -1 if unsuccesfull.
Adds an icon to the list.
------------------------------------------------------------------------------}
function TCustomImageList.AddIcon(Image: TIcon): Integer;
begin
//!!! check one or more
//No Icon Support yet
Result := -1;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.AddImages
Params: Value: An imagelist containing images to be added
Returns: Nothing
Adds images from another imagelist to the list.
------------------------------------------------------------------------------}
procedure TCustomImageList.AddImages(Value: TCustomImageList);
var
n: Integer;
Image, Mask: TBitmap;
begin
if Value = nil then exit;
Image:=nil;
Mask:=nil;
try
Image := TBitmap.Create;
with Image do begin
Height := FHeight;
Width := FWidth;
end;
Mask := TBitmap.Create;
with Mask do begin
Height := FHeight;
Width := FWidth;
end;
for n := 0 to Value.Count - 1 do begin
Value.GetImages(n, Image, Mask);
AddCopy(Image, Mask);
end;
Change;
finally
Image.Free;
Mask.Free;
end;
end;
{------------------------------------------------------------------------------
Function: TCustomImageList.AddMasked
Params: Image: A bitmap to be added
MaskColor: The color acting as transparant color
Returns: The index of the added icon, -1 if unsuccesfull.
Adds one or more (bitmap width / imagelist width) bitmaps to the list.
Every occurance of MaskColor will be converted to transparent.
------------------------------------------------------------------------------}
function TCustomImageList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
begin
try
Result := Count;
InsertMasked(Result, Image, MaskColor);
Change;
except
on E: Exception do begin
writeln('TCustomImageList.AddMasked ',E.Message);
Result := -1; // Ignore exceptions, just return -1
end;
end;
end;
{------------------------------------------------------------------------------
function TCustomImageList.AddFromLazarusResource(const ResourceName: string
): integer;
Load TBitmap from lazarus resources and add it.
------------------------------------------------------------------------------}
function TCustomImageList.AddFromLazarusResource(const ResourceName: string
): integer;
var
ABitmap: TBitmap;
begin
ABitmap:=TBitmap.Create;
ABitmap.LoadFromLazarusResource(ResourceName);
Result:=AddDirect(ABitmap,nil);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.AllocBitmap
Params: Amount: the amount of free image position which should be availabe
Returns: Nothing
Checks if there is enough space for Amount images, increases the internal
list if necessary .
------------------------------------------------------------------------------}
procedure TCustomImageList.AllocBitmap(Amount: Integer);
var
Num: 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);
FBitMap.Height := FBitMap.Height + Num * FAllocBy * FHeight;
FMaskBitmap.Height := FBitMap.Height;
Inc(FAllocCount, Num * FAllocBy);
end;
//raise Exception.Create('Unable to allocate bitmap space');
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Assign
Params: Source: Source data
Returns: Nothing
Very simple assign with stream exchange
------------------------------------------------------------------------------}
procedure TCustomImageList.Assign(Source: TPersistent);
Var
ImgSrc : TCustomImageList;
begin
if (Source=Self) then exit;
if Source is TCustomImageList then
begin
ImgSrc:=TCustomImageList(Source);
SetWidthHeight(ImgSrc.Width,ImgSrc.Height);
Clear;
AddImages(ImgSrc);
end
else inherited Assign(Source);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.AssignTo
Params: Dest: the destination to assign to
Returns: Nothing
Very simple assign with stream exchange
------------------------------------------------------------------------------}
procedure TCustomImageList.AssignTo(Dest: TPersistent);
begin
if Dest is TCustomImageList then
TCustomImageList(Dest).Assign(Self)
else
inherited AssignTo(Dest);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.BeginUpdate
Params: None
Returns: Nothing
Lock the change event for updating.
------------------------------------------------------------------------------}
procedure TCustomImageList.BeginUpdate;
begin
inc(FUpdateCount);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Change
Params: None
Returns: Nothing
Fires the change event.
------------------------------------------------------------------------------}
procedure TCustomImageList.Change;
begin
FChanged := true;
if FUpdateCount > 0 then exit;
NotifyChangeLink;
if Assigned(FOnChange) then FOnChange(Self);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Clear
Params: None
Returns: Nothing
Clears the list.
------------------------------------------------------------------------------}
procedure TCustomImageList.Clear;
begin
if FCount=0 then exit;
While Count<>0 do
Delete(0);
FCount := 0;
FImageList.Clear;
FMaskList.Clear;
Change;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Create
Params: AOwner: the owner of the class
Returns: Nothing
Constructor for the class.
------------------------------------------------------------------------------}
constructor TCustomImageList.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FHeight := 16;
FWidth := 16;
FImageList := TList.Create; //shane
FMaskList := TList.Create;
Initialize;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.CreateSize
Params: AHeight: The height of an image
AWidth: The width of an image
Returns: Nothing
Runtime constructor for the class with a given width and height.
------------------------------------------------------------------------------}
constructor TCustomImageList.CreateSize(AWidth, AHeight: Integer);
begin
inherited Create(nil);
FHeight := AHeight;
FWidth := AWidth;
FImageList := TList.Create; //shane
FMaskList := TList.Create;
Initialize;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.DefineProperties
Params: Filer: A filer for our properties
Returns: Nothing
Defines the images
------------------------------------------------------------------------------}
procedure TCustomImageList.DefineProperties(Filer: TFiler);
function DoWrite: Boolean;
begin
{ if Filer.Ancestor <> nil then
begin
Result := (not (Filer.Ancestor is TCustomImageList) or
not Equal(TCustomImageList(Filer.Ancestor)));
end
else
}
Result := Count > 0;
end;
begin
inherited DefineProperties(Filer);
Filer.DefineBinaryProperty('Bitmap', @ReadData, @WriteData, DoWrite);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Delete
Params: Index: the index of the image to be deleted.
Returns: Nothing
Deletes the image identified by Index. An index of -1 deletes all
------------------------------------------------------------------------------}
procedure TCustomImageList.Delete(Index: Integer);
Var Obj : TObject;
begin
if {(Index < 0) or} (Index >= FCount) // !! Delphi4 has no check for < -1
then raise EInvalidOperation.Create(SInvalidIndex);
if Index = -1 then
Clear
else
begin
Obj:=TObject(fImageList.Items[Index]);
If Assigned(Obj) then
Obj.Free;
fImageList.Items[Index]:=nil;
fImageList.Pack;
Obj:=TObject(fMaskList.Items[Index]);
If Assigned(Obj) then
Obj.Free;
fMaskList.Items[Index]:=nil;
fMaskList.Pack;
// ShiftImages(FBitmap.Canvas, Index, 1);
// ShiftImages(FMaskBitmap.Canvas, Index, 1);
Change;
end;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Destroy
Params: None
Returns: Nothing
Destructor for the class.
------------------------------------------------------------------------------}
destructor TCustomImageList.Destroy;
var
i: integer;
begin
FBitmap.Free;
FBitmap:=nil;
FMaskBitmap.Free;
FMaskBitmap:=nil;
for i:=0 to FImageList.Count-1 do TObject(FImageList[i]).Free;
for i:=0 to FMaskList.Count-1 do TObject(FMaskList[i]).Free;
FreeThenNil(FImageList); //shane
FreeThenNil(FMaskList); //shane
inherited Destroy;
FChangeLinkList.Free;
FChangeLinkList:=nil;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Draw
Params: Canvas: the canvas to draw on
X, Y: co-ordinates of the top, left corner of thetarget location
Index: index of the image to be drawn
Enabled: True, draws the image
False, draws the image disabled (embossed)
Returns: Nothing
Draws the requested image on the given canvas.
------------------------------------------------------------------------------}
procedure TCustomImageList.Draw(Canvas: TCanvas; X, Y, Index: Integer;
Enabled: Boolean);
var
aBitmap : TBitmap;
begin
if (FCount = 0) or (Index >= FCount) then Exit;
aBitmap := TBitmap(FImageList[Index]);
// ToDo: Mask
Canvas.CopyRect(Rect(X, Y, X + FWidth, Y + FHeight), aBitmap.Canvas,
Rect(0, 0, FWidth, FHeight));
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.EndUpdate
Params: none
Returns: Nothing
Decrements te update lock. When zero, changes are notified when necesary
------------------------------------------------------------------------------}
procedure TCustomImageList.EndUpdate;
begin
if FUpdateCount<=0 then
RaiseGDBException('');
dec(FUpdateCount);
if FChanged then begin
FChanged := False;
Change;
end;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.GetBitmap
Params: Index: the index of the requested image
Image: a bitmap as a container for the bitmap
Returns: Nothing
Creates a copy of the index'th image.
------------------------------------------------------------------------------}
procedure TCustomImageList.GetBitmap(Index: Integer; Image: TBitmap);
begin
if (FCount = 0) or (Image = nil) then Exit;
//writeln('TCustomImageList.GetBitmap Index=',Index,' Image=',HexStr(Cardinal(Image),8),' Bitmap=',HexStr(Cardinal(FImageList.Items[Index]),8));
Image.Assign(TBitMap(FImageList.Items[Index]));
end;
{------------------------------------------------------------------------------
procedure TCustomImageList.GetInternalImage(Index: integer; var Image,
Mask: TBitmap);
Fetches the index'th image. This is only available if there is one image
per index.
------------------------------------------------------------------------------}
procedure TCustomImageList.GetInternalImage(Index: integer; var Image,
Mask: TBitmap);
begin
Image:=TBitmap(FImageList[Index]);
Mask:=TBitmap(FMaskList[Index]);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.GetCount
Params:
Returns: Count
Returns the number of images.
------------------------------------------------------------------------------}
Function TCustomImageList.GetCount : Integer;
begin
Result := FImageList.Count;
FCount := Result;
end;
{------------------------------------------------------------------------------
Function: TCustomImageList.GetHotspot
Params: None
Returns: The co-ordinates for the hotspot of the drag image
Returns the co-ordinates for the hotspot of the drag image.
------------------------------------------------------------------------------}
function TCustomImageList.GetHotSpot: TPoint;
begin
Result := Point(0, 0);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.GetIcon
Params: Index: the index of the requested image
Image: an icon as a container for the bitmap
Returns: Nothing
Fetches the index'th image into an icon.
------------------------------------------------------------------------------}
procedure TCustomImageList.GetIcon(Index: Integer; Image: TIcon);
begin
if (Index < 0) or (Index >= FCount)
then raise EInvalidOperation.Create(SInvalidIndex);
//No Icon Support yet
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.GetImages
Params: Index: the index of the requested image
Image: a bitmap as a container for the bitmap
Mask: a bitmap as a container for the mask
Returns: Nothing
Fetches the index'th image and mask into a bitmap.
------------------------------------------------------------------------------}
procedure TCustomImageList.GetImages(Index: Integer; const Image, Mask: TBitmap);
begin
with Image do FBitmap.Canvas.CopyRect(
Rect(0, 0, Width, Height),
Canvas,
Rect(0, Index * FHeight, FWidth, (Index + 1) * FHeight)
);
with Mask do FMaskBitmap.Canvas.CopyRect(
Rect(0, 0, Width, Height),
Canvas,
Rect(0, Index * FHeight, FWidth, (Index + 1) * FHeight)
);
end;
{------------------------------------------------------------------------------
Function: TCustomImageList.HandleAllocated
Params: None
Returns: True if a handle is allocated
This function checks if the internal image is allocated
------------------------------------------------------------------------------}
function TCustomImageList.HandleAllocated: Boolean;
begin
Result := (FBitmap <> nil);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Initialize
Params: None
Returns: Nothing
Initializes the internal bitmap structures and the changelink list.
It is used by the Create and CreateSize constructors
------------------------------------------------------------------------------}
procedure TCustomImageList.Initialize;
begin
FChangeLinkList := TList.Create;
FAllocBy := 4;
FAllocCount := 0;
FBlendColor := clNone;
FBkColor := clNone;
if (Height < 1) or (Height > 32768) or (Width < 1)
then raise EInvalidOperation.Create(SInvalidImageSize);
FBitmap := TBitmap.Create;
FBitmap.Height := Height;
FBitmap.Width := Width;
FMaskBitmap := TBitmap.Create;
with FMaskBitmap do
begin
Height := Height;
Width := Width;
Canvas.Brush.Color := clWhite;
Monochrome := True;
end;
end;
procedure TCustomImageList.SetWidthHeight(NewWidth, NewHeight: integer);
begin
if (FHeight=NewHeight) and (FWidth=NewWidth) then exit;
FHeight := NewHeight;
FWidth := NewWidth;
FBitMap.Width := 0;
FBitMap.Height := 0;
AllocBitmap(0);
Clear;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Insert
Params: Index: the index of the inserted image
Image: a bitmap image
Mask: a bitmap which defines the transparent parts of Image
Returns: Nothing
Inserts one or more (bitmap width / imagelist width) bitmaps into the list
at the index'th position. If Mask is nil, the image has no transparent parts.
------------------------------------------------------------------------------}
procedure TCustomImageList.Insert(Index: Integer; Image, Mask: TBitmap);
//var
// n, nCount: Integer;
// I, M: TBitmap;
// DR, SR: TRect;
begin
if (Index > Count)
then raise EInvalidOperation.Create(SInvalidIndex);
if (Index < 0) then Index := 0;
if (Image <> nil)
then begin
FImageList.Insert(Index,Image);
FMaskList.Insert(Index,Mask);
Change;
{ nCount := Image.Width div FWidth;
if nCount > 0
then begin
AllocBitmap(nCount);
if Index <> FCount
then begin
ShiftImages(FBitmap.Canvas, Index, nCount);
ShiftImages(FMaskBitmap.Canvas, Index, nCount);
end;
Inc(FCount, nCount);
I := TBitmap.Create;
try
with I do
begin
Height := FHeight;
Width := FWidth;
end;
M := TBitmap.Create;
try
with M do
begin
Height := FHeight;
Width := FWidth;
end;
// insert the new images one by one
DR := Rect(0, 0, FWidth, FHeight);
SR := DR;
for n := Index to Index + nCount - 1 do
begin
CopyImage(I.Canvas, Image.Canvas, DR, SR);
if Mask = nil
then begin
Replace(n, I, nil);
end
else begin
CopyImage(M.Canvas, Mask.Canvas, DR, SR);
Replace(n, I, M);
end;
Inc(SR.Left, FWidth);
Inc(SR.Right, FWidth);
end;
finally
M.Free;
end;
finally
I.Free;
end;
end;
}
end;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.InsertIcon
Params: Index: the index of the inserted image
Image: the Icon to be inserted
Returns: Nothing
Inserts an icon into the list at the index'th position.
------------------------------------------------------------------------------}
procedure TCustomImageList.InsertIcon(Index: Integer; Image: TIcon);
begin
if (Index > FCount)
then raise EInvalidOperation.Create(SInvalidIndex);
if (Index < 0) then Index := 0;
//No Icon Support yet
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.InsertMasked
Params: Index: the index of the inserted image
Image: A bitmap to be inserted
MaskColor: The color acting as transparant color
Returns: Nothing
Adds one or more (bitmap width / imagelist width) bitmaps to the list.
Every occurance of MaskColor will be converted to transparent.
------------------------------------------------------------------------------}
procedure TCustomImageList.InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
var
Mask: TBitmap;
begin
Mask := TBitmap.Create;
try
with Mask do
begin
Height := Image.Height;
Width := Image.Width;
Assign(Image);
Mask(MaskColor);
end;
Insert(Index, Image, Mask);
Change;
finally
Mask.Free;
end;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Move
Params: CurIndex: the index of the image to be moved
NewIndex: the new index of the image
Returns: Nothing
Moves an image from the CurIndex'th location to NewIndex'th location
------------------------------------------------------------------------------}
procedure TCustomImageList.Move(CurIndex, NewIndex: Integer);
begin
if CurIndex <> NewIndex then begin
FImageList.Move(CurIndex,NewIndex);
FMaskList.Move(CurIndex,NewIndex);
Change;
end;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.NotifyChangeLink
Params: None
Returns: Nothing
Internal function to notify the subscribed objects of a change
of the imagelist.
------------------------------------------------------------------------------}
procedure TCustomImageList.NotifyChangeLink;
var
nIndex: Integer;
begin
if FChangeLinkList <> nil then
with FChangeLinkList do
for nIndex := 0 to Count - 1 do TChangeLink(Items[nIndex]).Change
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.ReadData
Params: AStream: The stream to read the data from
Returns: Nothing
Reads the imagelist data from stream
------------------------------------------------------------------------------}
procedure TCustomImageList.ReadData(AStream: TStream);
procedure DoReadLaz1;
var
i, NewCount, Size: Integer;
bmp: TBitmap;
begin
// provided for compatebility for earlier lazarus streams
NewCount := AStream.ReadWord;
for i := 0 to NewCount - 1 do
begin
bmp := TBitMap.Create;
AStream.Read(Size, SizeOf(Size));
bmp.ReadStream(AStream, True, Size);
bmp.Transparent := True;
AddDirect(bmp, nil);
end;
end;
var
Signature: array[0..1] of Char;
StreamPos: TStreamSeekType;
Image, Img, Mask, Msk: TBitmap;
Row, Col, Size, NewCount: Integer;
SrcRect: TRect;
HasMask: Boolean;
begin
Clear;
StreamPos := AStream.Position; // check stream signature
AStream.Read(Signature, SizeOf(Signature));
if Signature = SIG_LAZ1
then begin
DoReadLaz1;
Exit;
end;
Image := nil;
Mask := nil;
try
Image := TBitmap.Create;
Mask := TBitmap.Create;
if Signature = SIG_D3
then begin
AStream.ReadWord; //Skip ?
NewCount := AStream.ReadWord;
//writeln('NewCount=',NewCount);
AStream.ReadWord; //Skip Capacity
AStream.ReadWord; //Skip Grow
FWidth := AStream.ReadWord;
//writeln('NewWidth=',FWidth);
FHeight := AStream.ReadWord;
//writeln('NewHeight=',FHeight);
FBKColor := TColor(AStream.ReadDWord);
HasMask := (AStream.ReadWord and 1) = 1;
AStream.ReadDWord; //Skip ?
AStream.ReadDWord; //Skip ?
//writeln('TCustomImageList.ReadData After Header ',FWidth,',',FHeight,' ',AStream.Position,'/',AStream.Size);
Image.ReadStream(AStream,false,0);
//Image.SaveToFile('output_test.bmp');
//writeln('TCustomImageList.ReadData After Image ',Image.Width,',',Image.Height,' Masked=',Image.MaskHandleAllocated,' StreamPos=',AStream.Position,'/',AStream.Size,' HasMask=',HasMask);
if HasMask then begin
Mask.ReadStream(AStream,false,0);
//writeln('TCustomImageList.ReadData After Mask ',Mask.Width,',',Mask.Height,' StreamPos=',AStream.Position,'/',AStream.Size,' ');
end;
end
else begin
// D2 has no signature, so restore original position
AStream.Position := StreamPos;
AStream.ReadBuffer(Size, SizeOf(Size));
AStream.ReadBuffer(NewCount, SizeOf(NewCount));
Image.ReadStream(AStream,false,0);
AStream.Position := StreamPos + Size;
HasMask := True;
if HasMask then
Mask.ReadStream(AStream,false,0);
end;
// ATM we are creating one image/mask for each icon.
// But eventually there should only be one TBitmap.
SrcRect := Bounds(0, 0, Width, Height);
BeginUpdate;
try
for Row := 0 to (Image.Height div Height) - 1 do
begin
if NewCount <= 0 then Break;
for Col := 0 to (Image.Width div Width) - 1 do
begin
if NewCount <= 0 then Break;
Img := TBitmap.Create;
Img.Width := Width;
Img.Height := Height;
Img.Canvas.CopyRect(SrcRect, Image.Canvas,
Bounds(Col * Width, Row * Height, Width, Height));
//Img.Canvas.Brush.Color:=clRed;
//Img.Canvas.Fillrect(Rect(3,3,10,8));
//Img.SaveToFile('debug_imglist_i'+IntToStr(Count)+'.bmp');
if Mask<>nil then begin
Msk := TBitmap.Create;
Msk.Monochrome := True;
Msk.Width := Width;
Msk.Height := Height;
Msk.Canvas.CopyRect(SrcRect, Mask.Canvas,
Bounds(Col * Width, Row * Height, Width, Height));
//Msk.SaveToFile('debug_imglist_m'+IntToStr(Count)+'.bmp');
// ToDo: combine image and mask
end else
Msk:=nil;
AddDirect(Img, Msk);
Img := nil;
Msk := nil;
Dec(NewCount);
end;
end;
finally
Img.Free;
Msk.Free;
EndUpdate;
end;
finally
Image.Free;
Mask.Free;
end;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.RegisterChanges
Params: Value: a reference to changelink object
Returns: Nothing
Registers an object to get notified of a change of the imagelist.
------------------------------------------------------------------------------}
procedure TCustomImageList.RegisterChanges(Value: TChangeLink);
begin
if (Value <> nil) and (FChangeLinkList.IndexOf(Value) = -1)
then begin
Value.Sender := Self;
FChangeLinkList.Add(Value);
end;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Replace
Params: Index: the index of the replaceded image
Image: a bitmap image
Mask: a bitmap which defines the transparent parts of Image
Returns: Nothing.
Replaces the index'th image with the image given. If Mask is nil,
the image has no transparent parts.
------------------------------------------------------------------------------}
procedure TCustomImageList.Replace(Index: Integer; Image, Mask: TBitmap);
var
DestinationRect, SourceRect: TRect;
begin
if (Index >= FCount)
then raise EInvalidOperation.Create(SInvalidIndex);
if (Index < 0) then Index := 0;
DestinationRect := Rect(0, Index * FHeight, FWidth, (Index + 1) * FHeight);
SourceRect := Rect(0, 0, FWidth, FHeight);
CopyImage(FBitmap.Canvas, Image.Canvas, DestinationRect, SourceRect);
if Mask <> nil
then CopyImage(FMaskBitmap.Canvas, Mask.Canvas, DestinationRect, SourceRect)
else FMaskBitmap.Canvas.FillRect(DestinationRect);
Change;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Replace
Params: Index: the index of the replaceded image
Image: an icon image
Returns: Nothing.
Replaces the index'th image with the image given.
------------------------------------------------------------------------------}
procedure TCustomImageList.ReplaceIcon(Index: Integer; Image: TIcon);
begin
if (Index > FCount)
then raise EInvalidOperation.Create(SInvalidIndex);
if (Index < 0) then Index := 0;
// No Icon suppport yet
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.ReplaceMasked
Params: Index: the index of the replaceded image
Image: A bitmap image
MaskColor: The color acting as transparant color
Returns: Nothing
Replaces the index'th image with the image given.
Every occurance of MaskColor will be converted to transparent.
------------------------------------------------------------------------------}
procedure TCustomImageList.ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor);
begin
if (Index >= FCount)
then raise EInvalidOperation.Create(SInvalidIndex);
if (Index < 0) then Index := 0;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.SetBkColor
Params: Value: The background color
Returns: Nothing
Sets the backgroundcolor for the transparen parts.
------------------------------------------------------------------------------}
procedure TCustomImageList.SetBkColor(const Value: TColor);
begin
if FBkColor <> Value
then begin
FBkColor := Value;
Change;
end;
end;
procedure TCustomImageList.SetDrawingStyle(const AValue: TDrawingStyle);
begin
if FDrawingStyle=AValue then exit;
FDrawingStyle:=AValue;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.SetHeight
Params: Value: the height of an image
Returns: Nothing
Sets the height of an image. If the height differs from the original height,
the list contents wil be deleted.
------------------------------------------------------------------------------}
procedure TCustomImageList.SetHeight(const Value: Integer);
begin
SetWidthHeight(Width,Value);
end;
procedure TCustomImageList.SetMasked(const AValue: boolean);
begin
if FMasked=AValue then exit;
FMasked:=AValue;
end;
procedure TCustomImageList.SetShareImages(const AValue: Boolean);
begin
if FShareImages=AValue then exit;
FShareImages:=AValue;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.SetWidth
Params: Value: the width of an image
Returns: Nothing
Sets the width of an image. If the width differs from the original width,
the list contents wil be deleted.
------------------------------------------------------------------------------}
procedure TCustomImageList.SetWidth(const Value: Integer);
begin
SetWidthHeight(Value,Height);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.ShiftImages
Params: Source: source canvas on which the images are moved
Start: start of the image to shift
Shift: number of images to shift
Returns: Nothing
Internal routine to move images on the internal image list.
------------------------------------------------------------------------------}
procedure TCustomImageList.ShiftImages(const Source: TCanvas;
Start, Shift: Integer);
var
FMoveBitmap: TBitmap;
begin
try
FMoveBitmap := TBitmap.Create;
with FMoveBitmap do
begin
Width := FWidth;
Height := (1 + FCount - Start) * FHeight;
end;
FMoveBitmap.Canvas.CopyRect(
Rect(0, 0, FWidth, FMoveBitmap.Height),
Source,
Rect(0, Start * FHeight, FWidth, (FCount + 1) * FHeight)
);
Source.CopyRect(
Rect(0, (Start + Shift) * FHeight, FWidth, (FCount + Shift + 1) * FHeight),
FMoveBitmap.Canvas,
Rect(0, 0, FWidth, FMoveBitmap.Height)
);
finally
FMoveBitmap.Free;
end;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.UnRegisterChanges
Params: Value: a reference to changelink object
Returns: Nothing
Unregisters an object for notifications.
------------------------------------------------------------------------------}
procedure TCustomImageList.UnRegisterChanges(Value: TChangeLink);
begin
if (FChangeLinkList<>nil) and (Value.Sender=Self) then
FChangeLinkList.Remove(Value);
Value.Sender:=nil;
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.WriteData
Params: AStream: The stream to write the data to
Returns: Nothing
Writes the imagelist data to stream
------------------------------------------------------------------------------}
procedure TCustomImageList.WriteData(AStream: TStream);
var
CurImage, CurMask: TBitMap;
i: Integer;
begin
//Write signature
AStream.WriteWord($0001);
//Count of image
AStream.WriteWord(Word(Count));
for i:=0 to Count-1 do
begin
GetInternalImage(i,CurImage,CurMask);
CurImage.WriteStream(AStream,true);
end;
end;
{******************************************************************************
TChangeLink
******************************************************************************}
{------------------------------------------------------------------------------
Method: TChangeLink.Change
Params: None
Returns: Nothing
Fires the OnChange event.
------------------------------------------------------------------------------}
procedure TChangeLink.Change;
begin
if Assigned(FOnChange) then FOnChange(Sender)
end;
{------------------------------------------------------------------------------
Method: TChangeLink.Destroy
Params: None
Returns: Nothing
Destructor for the class.
------------------------------------------------------------------------------}
destructor TChangeLink.Destroy;
begin
if Sender <> nil
then Sender.UnRegisterChanges(Self);
inherited Destroy;
end;
// included by imglist.pp
{
$Log$
Revision 1.29 2004/03/02 22:37:36 mattias
clean up for TBitmapImage sharing
Revision 1.28 2004/03/01 23:45:33 marc
* Patch from olivier GUILBAUD and Colin Western
* fixed addcopy
Revision 1.27 2004/02/29 22:51:54 mattias
added jpeg example
Revision 1.26 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.25 2004/02/25 11:12:06 marc
+ Added delphi stream reading support
Revision 1.24 2004/02/24 19:40:17 mattias
TBitmap can now read form streams without knowing the size
Revision 1.23 2004/02/22 10:43:20 mattias
added child-parent checks
Revision 1.22 2004/02/02 21:31:08 mattias
reduced output
Revision 1.21 2004/02/02 19:13:31 mattias
started reading TImageList in Delphi format
Revision 1.20 2004/02/02 16:59:28 mattias
more Actions TAction, TBasicAction, ...
Revision 1.19 2003/12/25 14:17:07 mattias
fixed many range check warnings
Revision 1.18 2003/11/08 23:42:24 mattias
fixed unregistering imageslink
Revision 1.17 2003/03/11 07:46:43 mattias
more localization for gtk- and win32-interface and lcl
Revision 1.16 2003/02/27 09:52:00 mattias
published TImgList.Width and Height
Revision 1.15 2003/02/26 23:31:53 mattias
added imagelisteditor from Olivier
Revision 1.14 2002/12/16 12:12:50 mattias
fixes for fpc 1.1
Revision 1.13 2002/11/09 15:02:07 lazarus
MG: fixed LM_LVChangedItem, OnShowHint, small bugs
Revision 1.12 2002/08/22 13:45:58 lazarus
MG: fixed non AutoCheck menuitems and editor bookmark popupmenu
Revision 1.11 2002/06/08 17:16:02 lazarus
MG: added close buttons and images to TNoteBook and close buttons to source editor
Revision 1.10 2002/05/10 06:05:52 lazarus
MG: changed license to LGPL
Revision 1.9 2002/04/04 12:25:01 lazarus
MG: changed except statements to more verbosity
Revision 1.8 2002/01/07 13:58:15 lazarus
Changes to TListView to display images and fixes to TCustomImageList to notify it's owners of changes.
Shane
Revision 1.7 2002/01/03 15:07:08 lazarus
MG: fixed TCustomImageList.CreateSize
Revision 1.6 2001/06/14 14:57:58 lazarus
MG: small bugfixes and less notes
Revision 1.5 2001/03/19 14:40:49 lazarus
MG: fixed many unreleased DC and GDIObj bugs
Revision 1.3 2001/02/06 13:55:23 lazarus
Changed the files from mode delphi to mode objfpc
Shane
Revision 1.2 2001/01/11 20:16:47 lazarus
Added some TImageList code.
Added a bookmark resource with 10 resource images.
Removed some of the IFDEF's in mwCustomEdit around the inherited code.
Shane
Revision 1.1 2000/07/13 10:28:26 michael
+ Initial import
Revision 1.1 2000/04/02 20:49:56 lazarus
MWE:
Moved lazarus/lcl/*.inc files to lazarus/lcl/include
Revision 1.5 2000/03/21 23:47:33 lazarus
MWE:
+ Added TBitmap.MaskHandle & TGraphic.Draw & TBitmap.Draw
Revision 1.4 1999/09/26 17:06:44 lazarus
MWE: Exept for resource loading, streaming and icons, finished
implementation of TCustomImageList.
Revision 1.3 1999/09/26 15:37:20 lazarus
MWE: implemented some more methods and documented most
Revision 1.2 1999/08/20 15:44:39 lazarus
TImageList changes added from Marc Weustink
Revision 1.1 1999/08/12 16:22:19 lazarus
Templates initially created CAW
}
Reference in New Issue View Git Blame Copy Permalink