mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-12 14:29:36 +02:00
made TIcon more independent of TBitmap from Colin
git-svn-id: trunk@5404 -
This commit is contained in:
mattias
parent
723d653f98
commit
eaf26981f3
@ -38,7 +38,7 @@ interface
|
||||
|
||||
|
||||
uses
|
||||
SysUtils, Classes, FPCAdds,
|
||||
SysUtils, Classes, Contnrs, FPCAdds,
|
||||
{$IFNDEF DisableFPImage}
|
||||
FPImage, FPReadPNG, FPWritePNG, FPReadBMP, FPWriteBMP, IntfGraphics,
|
||||
{$ENDIF}
|
||||
@ -998,9 +998,6 @@ type
|
||||
procedure WriteData(Stream: TStream); override;
|
||||
procedure StoreOriginalStream(Stream: TStream; Size: integer); virtual;
|
||||
{$IFNDEF DisableFPImage}
|
||||
procedure ReadStreamWithFPImage(Stream: TStream; UseSize: boolean;
|
||||
Size: Longint;
|
||||
ReaderClass: TFPCustomImageReaderClass); virtual;
|
||||
procedure WriteStreamWithFPImage(Stream: TStream; WriteSize: boolean;
|
||||
WriterClass: TFPCustomImageWriterClass); virtual;
|
||||
procedure InitFPImageReader(ImgReader: TFPCustomImageReader); virtual;
|
||||
@ -1041,6 +1038,9 @@ type
|
||||
const FileExtension: string): TFPCustomImageWriterClass; override;
|
||||
class function GetDefaultFPReader: TFPCustomImageReaderClass; override;
|
||||
class function GetDefaultFPWriter: TFPCustomImageWriterClass; override;
|
||||
procedure ReadStreamWithFPImage(Stream: TStream; UseSize: boolean;
|
||||
Size: Longint;
|
||||
ReaderClass: TFPCustomImageReaderClass); virtual;
|
||||
procedure WriteNativeStream(Stream: TStream; WriteSize: Boolean;
|
||||
SaveStreamType: TBitmapNativeType); virtual;
|
||||
{$ENDIF}
|
||||
@ -1110,11 +1110,25 @@ type
|
||||
{ TIcon }
|
||||
{
|
||||
TIcon reads and writes .ICO file format.
|
||||
! Currently it is almost a TBitmap !
|
||||
A .ico file typically contains several versions of the same image. When loading,
|
||||
the largest/most colourful image is loaded as the TBitmap and so can be handled
|
||||
as any other bitmap. Any other versions of the images are available via the
|
||||
Bitmaps property
|
||||
Writing is not (yet) implemented.
|
||||
}
|
||||
TIcon = class(TBitmap)
|
||||
{$IFNDEF DisableFPImage}
|
||||
private
|
||||
FBitmaps: TObjectList;
|
||||
protected
|
||||
procedure ReadData(Stream: TStream); override;
|
||||
procedure InitFPImageReader(ImgReader: TFPCustomImageReader); override;
|
||||
public
|
||||
class function GetFileExtensions: string; override;
|
||||
property Bitmaps: TObjectList read FBitmaps;
|
||||
destructor Destroy; override;
|
||||
procedure AddBitmap(Bitmap: TBitmap); { Note that Ownership passes to TIcon }
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
@ -1588,6 +1602,11 @@ end;
|
||||
|
||||
{ TIcon }
|
||||
|
||||
{$IFNDEF DisableFPImage}
|
||||
|
||||
const
|
||||
IconSignature: array [0..3] of char = #0#0#1#0;
|
||||
|
||||
function TestStreamIsIcon(const AStream: TStream): boolean;
|
||||
var
|
||||
Signature: array[0..3] of char;
|
||||
@ -1596,7 +1615,7 @@ var
|
||||
begin
|
||||
OldPosition:=AStream.Position;
|
||||
ReadSize:=AStream.Read(Signature, SizeOf(Signature));
|
||||
Result:=(ReadSize=SizeOf(Signature)) and (Signature=#0#0#1#0);
|
||||
Result:=(ReadSize=SizeOf(Signature)) and CompareMem(@Signature,@IconSignature,4);
|
||||
AStream.Position:=OldPosition;
|
||||
end;
|
||||
|
||||
@ -1606,8 +1625,8 @@ var
|
||||
Position: TStreamSeekType;
|
||||
begin
|
||||
Position := Stream.Position;
|
||||
Stream.Read(Size, SizeOf(Size));
|
||||
if Size = $10000 then begin // Icon starts 00 00 01 00
|
||||
Stream.Read(Size, 4); // Beware BigEndian and LowEndian sytems
|
||||
if CompareMem(@Size,@IconSignature,4) then begin
|
||||
// Assume Icon - stream without explicit size
|
||||
Stream.Position := Position;
|
||||
ReadStream(Stream, false, Size);
|
||||
@ -1615,6 +1634,32 @@ begin
|
||||
ReadStream(Stream, true, Size);
|
||||
end;
|
||||
|
||||
procedure TIcon.InitFPImageReader(ImgReader: TFPCustomImageReader);
|
||||
begin
|
||||
inherited InitFPImageReader(ImgReader);
|
||||
if ImgReader is TLazReaderIcon then
|
||||
TLazReaderIcon(ImgReader).Icon := self;
|
||||
end;
|
||||
|
||||
function TIcon.GetFileExtensions: string;
|
||||
begin
|
||||
Result:='ico';
|
||||
end;
|
||||
|
||||
destructor TIcon.Destroy;
|
||||
begin
|
||||
inherited Destroy;
|
||||
FreeAndNil(FBitmaps);
|
||||
end;
|
||||
|
||||
procedure TIcon.AddBitmap(Bitmap: TBitmap);
|
||||
begin
|
||||
if not Assigned(FBitmaps) then
|
||||
FBitmaps := TObjectList.create(True);
|
||||
FBitmaps.Add(Bitmap);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
initialization
|
||||
PicClipboardFormats:=nil;
|
||||
PicFileFormats:=nil;
|
||||
@ -1636,6 +1681,9 @@ end.
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.134 2004/04/12 22:36:29 mattias
|
||||
made TIcon more independent of TBitmap from Colin
|
||||
|
||||
Revision 1.133 2004/04/10 14:20:20 mattias
|
||||
fixed saving findtext from vincent
|
||||
|
||||
|
||||
@ -50,9 +50,7 @@ begin
|
||||
{$IFNDEF DisableFPImage}
|
||||
Add('png', 'Portable Network Graphic', TPortableNetworkGraphic);
|
||||
{$ENDIF}
|
||||
{$IFDEF HasIconGraphic}
|
||||
Add('ico', 'Icon', TIcon);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TPicFileFormatsList.Clear;
|
||||
|
||||
@ -3105,9 +3105,8 @@ var
|
||||
UnRef : Boolean;
|
||||
DCOrigin: TPoint;
|
||||
UnderLine: boolean;
|
||||
|
||||
buffer : PGdkPixmap;
|
||||
buffered : boolean;
|
||||
buffer: PGdkDrawable;
|
||||
buffered: Boolean;
|
||||
|
||||
procedure DrawTextLine;
|
||||
var
|
||||
@ -3202,25 +3201,12 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
//If we don't have double buffering, try and buffer each block of text,
|
||||
//otherwise most text "flashes" by disapearing and then redrawing on account
|
||||
//of the two passes, first one to draw bg and then another to draw fg.
|
||||
|
||||
//By doing it this way the "constant" flashing is replaced by more occasional
|
||||
//flashing, and is primarily restricted to the larger blocks of text. Far
|
||||
//more pleasant to work with, especially in the Lazarus Source Editor where
|
||||
//each keyword, string, etc is its own block drawn individually, thus is
|
||||
//constantly flashing during code changes, resizing, scrolling, etc.
|
||||
if ((Options and ETO_OPAQUE) <> 0) then
|
||||
begin
|
||||
Width := Rect^.Right - Rect^.Left;
|
||||
Height := Rect^.Bottom - Rect^.Top;
|
||||
SelectedColors := dcscCustom;
|
||||
EnsureGCColor(DC, dccCurrentBackColor, True, False);
|
||||
{$IFDEF EnableDoubleBuf}
|
||||
buffered := True;
|
||||
buffer := gdk_pixmap_new(Drawable, Width, Height, -1);
|
||||
{$ENDIF}
|
||||
if buffered then begin
|
||||
Left:=0;
|
||||
Top:=0;
|
||||
@ -3285,13 +3271,6 @@ begin
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
if buffered then begin
|
||||
BeginGDKErrorTrap;
|
||||
gdk_draw_pixmap(drawable, gc, buffer, 0,0, Rect^.Left+DCOrigin.X,
|
||||
Rect^.Top+DCOrigin.Y, Width, Height);
|
||||
gdk_pixmap_unref(buffer);
|
||||
EndGDKErrorTrap;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
Assert(False, Format('trace:< [TGtkWidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
|
||||
@ -8715,6 +8694,9 @@ end;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.346 2004/04/12 22:36:29 mattias
|
||||
made TIcon more independent of TBitmap from Colin
|
||||
|
||||
Revision 1.345 2004/04/03 16:47:46 mattias
|
||||
implemented converting gdkbitmap to RawImage mask
|
||||
|
||||
|
||||
@ -128,6 +128,7 @@ type
|
||||
FAlphaReadRawImageBits: TOnReadRawImageBits;
|
||||
FAlphaWriteRawImageBits: TOnWriteRawImageBits;
|
||||
procedure SetAutoCreateMask(const AValue: boolean);
|
||||
procedure SetUsePalette (Value:boolean);override;
|
||||
protected
|
||||
OnGetInternalColor: TOnGetLazIntfImagePixel;
|
||||
OnSetInternalColor: TOnSetLazIntfImagePixel;
|
||||
@ -334,6 +335,7 @@ type
|
||||
ReadPalette: Boolean); virtual;
|
||||
procedure ReadScanLine(Row: Integer; Stream: TStream); virtual;
|
||||
procedure WriteScanLine(Row: Integer; Img: TFPCustomImage); virtual;
|
||||
function BmpRGBAToFPColor(Const RGBA: TColorRGBA): TFPcolor; virtual;
|
||||
// required by TFPCustomImageReader
|
||||
procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
|
||||
procedure InternalReadBody(Stream: TStream; Img: TFPCustomImage);
|
||||
@ -343,16 +345,30 @@ type
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
{ TLazReaderIcon }
|
||||
{ This is a FPImage writer for icon images. }
|
||||
TLazReaderIcon = class (TLazReaderBMP)
|
||||
private
|
||||
FnIcons: Integer;
|
||||
FnStartPos: TStreamSeekType;
|
||||
{ TLazReaderPartIcon }
|
||||
{ This is a FPImage writer for a single icon from an icon file }
|
||||
TLazReaderPartIcon = class (TLazReaderBMP)
|
||||
protected
|
||||
// required by TFPCustomImageReader
|
||||
procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
|
||||
function InternalCheck(Stream: TStream) : boolean; override;
|
||||
function BmpRGBAToFPColor(Const RGBA: TColorRGBA): TFPcolor; override;
|
||||
end;
|
||||
|
||||
{ TLazReaderIcon }
|
||||
{ This is a FPImage writer for icon images. }
|
||||
TLazReaderIcon = class (TLazReaderPartIcon)
|
||||
private
|
||||
FIcon: TObject; { Actually TIcon, but this would give rise to a circular reference }
|
||||
FnIcons: Integer;
|
||||
FnStartPos: TStreamSeekType;
|
||||
procedure SetIcon(const AValue: TObject);
|
||||
protected
|
||||
// required by TFPCustomImageReader
|
||||
procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
|
||||
function InternalCheck(Stream: TStream) : boolean; override;
|
||||
public
|
||||
property Icon: TObject read FIcon write SetIcon;
|
||||
end;
|
||||
|
||||
function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
|
||||
@ -361,6 +377,8 @@ procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
|
||||
|
||||
implementation
|
||||
|
||||
uses Graphics;
|
||||
|
||||
var
|
||||
IsSpaceChar, IsNumberChar, IsHexNumberChar: array[char] of Boolean;
|
||||
|
||||
@ -1374,6 +1392,11 @@ begin
|
||||
FreeMaskData;
|
||||
end;
|
||||
|
||||
procedure TLazIntfImage.SetUsePalette(Value: boolean);
|
||||
begin
|
||||
inherited SetUsePalette(False); // Can't handle palettes at the moment
|
||||
end;
|
||||
|
||||
procedure TLazIntfImage.SetInternalColor(x, y: integer; const Value: TFPColor);
|
||||
begin
|
||||
{if (x=0) and (y=0) then begin
|
||||
@ -2870,34 +2893,19 @@ end;
|
||||
|
||||
{ TLazReaderBMP }
|
||||
|
||||
type
|
||||
TColorBmpRGB=packed record
|
||||
B,G,R: Byte;
|
||||
end;
|
||||
PColorBmpRGB = ^TColorBmpRGB;
|
||||
|
||||
TColorBmpRGBA=packed record
|
||||
case Boolean of
|
||||
False:(B,G,R,A: Byte);
|
||||
True:(RGB: TColorBmpRGB);
|
||||
end;
|
||||
PColorBmpRGBA = ^TColorBmpRGBA;
|
||||
|
||||
function BmpRGBAToFPColor(Const RGBA: TColorBmpRGBA): TFPcolor;
|
||||
var
|
||||
NewAlpha: Byte;
|
||||
function TLazReaderBMP.BmpRGBAToFPColor(Const RGBA: TColorRGBA): TFPcolor;
|
||||
begin
|
||||
with Result, RGBA do
|
||||
begin
|
||||
Red :=(R shl 8) or R;
|
||||
Green :=(G shl 8) or G;
|
||||
Blue :=(B shl 8) or B;
|
||||
NewAlpha:=255-A;
|
||||
alpha :=(NewAlpha shl 8) or NewAlpha;
|
||||
// Specification for bitmap files has these bits always zero - unused
|
||||
alpha := alphaOpaque;
|
||||
end;
|
||||
end;
|
||||
|
||||
Function BmpRGBToFPColor(Const RGB: TColorBmpRGB) : TFPColor;
|
||||
Function BmpRGBToFPColor(Const RGB: TColorRGB) : TFPColor;
|
||||
begin
|
||||
with Result,RGB do
|
||||
begin
|
||||
@ -2941,48 +2949,55 @@ procedure TLazReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream: TStream;
|
||||
ReadPalette: Boolean);
|
||||
{$ifdef VER1_0}
|
||||
type
|
||||
tcolinfo = ARRAY [0..0] OF TColorBmpRGBA;
|
||||
tcolinfo = ARRAY [0..0] OF TColorRGBA;
|
||||
pcolinfo = ^tcolinfo;
|
||||
var
|
||||
ColInfo: pcolinfo;
|
||||
{$else}
|
||||
var
|
||||
ColInfo: ARRAY OF TColorBmpRGBA;
|
||||
ColInfo: ARRAY OF TColorRGBA;
|
||||
{$endif}
|
||||
i: Integer;
|
||||
FPcolor: TFPcolor;
|
||||
begin
|
||||
if nPalette>0 then
|
||||
begin
|
||||
GetMem(FPalette, nPalette*SizeOf(TFPColor));
|
||||
{$ifdef VER1_0}
|
||||
GetMem(ColInfo, nPalette*Sizeof(TColorBmpRGBA));
|
||||
GetMem(ColInfo, nPalette*Sizeof(TColorRGBA));
|
||||
if ReadPalette then begin
|
||||
if BFI.biClrUsed>0 then
|
||||
Stream.Read(ColInfo^[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
|
||||
Stream.Read(ColInfo^[0],BFI.biClrUsed*SizeOf(TColorRGBA))
|
||||
else // Seems to me that this is dangerous.
|
||||
Stream.Read(ColInfo^[0],nPalette*SizeOf(TColorBmpRGBA));
|
||||
for i := 0 to nPalette-1 do
|
||||
FPalette[i] := BmpRGBAToFPColor(ColInfo^[i]);
|
||||
Stream.Read(ColInfo^[0],nPalette*SizeOf(TColorRGBA));
|
||||
for i := 0 to nPalette-1 do begin
|
||||
FPcolor := BmpRGBAToFPColor(ColInfo^[i]);
|
||||
FPcolor.alpha := alphaOpaque; { No transparency info in palette }
|
||||
FPalette[i] := FPcolor;
|
||||
end;
|
||||
end;
|
||||
{$else}
|
||||
SetLength(ColInfo, nPalette);
|
||||
if ReadPalette then begin
|
||||
if BFI.biClrUsed>0 then
|
||||
Stream.Read(ColInfo[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
|
||||
Stream.Read(ColInfo[0],BFI.biClrUsed*SizeOf(TColorRGBA))
|
||||
else // Seems to me that this is dangerous.
|
||||
Stream.Read(ColInfo[0],nPalette*SizeOf(TColorBmpRGBA));
|
||||
for i := 0 to High(ColInfo) do
|
||||
FPalette[i] := BmpRGBAToFPColor(ColInfo[i]);
|
||||
Stream.Read(ColInfo[0],nPalette*SizeOf(TColorRGBA));
|
||||
for i := 0 to nPalette-1 do begin
|
||||
FPcolor := BmpRGBAToFPColor(ColInfo[i]);
|
||||
FPcolor.alpha := alphaOpaque; { No transparency info in palette }
|
||||
FPalette[i] := FPcolor;
|
||||
end;
|
||||
end;
|
||||
{$endif}
|
||||
end
|
||||
else if BFI.biClrUsed>0 then { Skip palette }
|
||||
Stream.Position := Stream.Position
|
||||
+ TStreamSeekType(BFI.biClrUsed*SizeOf(TColorBmpRGBA));
|
||||
+ TStreamSeekType(BFI.biClrUsed*SizeOf(TColorRGBA));
|
||||
ReadSize:=((nRowBits + 31) div 32) shl 2;
|
||||
GetMem(LineBuf,ReadSize);
|
||||
{$ifdef VER1_0}
|
||||
FreeMem(ColInfo, nPalette*Sizeof(TColorBmpRGBA));
|
||||
FreeMem(ColInfo, nPalette*Sizeof(TColorRGBA));
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
@ -3016,10 +3031,10 @@ begin
|
||||
img.colors[Column,Row]:=Bmp16BitToFPColor(PWord(LineBuf)[Column]);
|
||||
24 :
|
||||
for Column:=0 to img.Width-1 do
|
||||
img.colors[Column,Row]:=BmpRGBToFPColor(PColorBmpRGB(LineBuf)[Column]);
|
||||
img.colors[Column,Row]:=BmpRGBToFPColor(PColorRGB(LineBuf)[Column]);
|
||||
32 :
|
||||
for Column:=0 to img.Width-1 do
|
||||
img.colors[Column,Row]:=BmpRGBAToFPColor(PColorBmpRGBA(LineBuf)[Column]);
|
||||
img.colors[Column,Row]:=BmpRGBAToFPColor(PColorRGBA(LineBuf)[Column]);
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -3034,7 +3049,7 @@ Var
|
||||
Row : Integer;
|
||||
begin
|
||||
{ This will move past any junk after the BFI header }
|
||||
Stream.Position:=Stream.Position-TStreamSeekType(SizeOf(BFI)-BFI.biSize);
|
||||
Stream.Position:=Stream.Position+TStreamSeekType(BFI.biSize-SizeOf(BFI));
|
||||
with BFI do
|
||||
begin
|
||||
if (biCompression<>0) then
|
||||
@ -3138,6 +3153,43 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TLazReaderPartIcon }
|
||||
|
||||
procedure TLazReaderPartIcon.InternalRead(Stream: TStream; Img: TFPCustomImage);
|
||||
var
|
||||
Row, Column: Integer;
|
||||
begin
|
||||
Stream.Read(BFI,SizeOf(BFI));
|
||||
BFI.biHeight := BFI.biHeight div 2; { Height field is doubled, to (sort of) accomodate mask }
|
||||
InternalReadBody(Stream, Img); { Now read standard bitmap }
|
||||
{ Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header }
|
||||
if BFI.biBitCount < 32 then begin
|
||||
ReadSize:=((Img.Width + 31) div 32) shl 2;
|
||||
SetupRead(2,Img.Width,Stream,False);
|
||||
try
|
||||
for Row:=Img.Height-1 downto 0 do begin
|
||||
ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
|
||||
for Column:=0 to Img.Width-1 do
|
||||
if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
|
||||
img.colors[Column,Row]:=colTransparent
|
||||
end;
|
||||
finally
|
||||
FreeBufs;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TLazReaderPartIcon.InternalCheck(Stream: TStream): boolean;
|
||||
begin
|
||||
Result:=True; { Assumes stream in the correct place }
|
||||
end;
|
||||
|
||||
function TLazReaderPartIcon.BmpRGBAToFPColor(const RGBA: TColorRGBA): TFPcolor;
|
||||
begin
|
||||
Result:=inherited BmpRGBAToFPColor(RGBA);
|
||||
Result.alpha := (RGBA.A shl 8) or RGBA.A; { For icon files (only) upper byte is used for transparency }
|
||||
end;
|
||||
|
||||
{ TLazReaderIcon }
|
||||
|
||||
type
|
||||
@ -3159,45 +3211,63 @@ type
|
||||
dwImageOffset: Longint; {pos of image as offset from the beginning of file}
|
||||
end;
|
||||
|
||||
PIconDirEntry = ^TIconDirEntry;
|
||||
|
||||
procedure TLazReaderIcon.SetIcon(const AValue: TObject);
|
||||
begin
|
||||
if AValue is TIcon then
|
||||
FIcon:=AValue;
|
||||
end;
|
||||
|
||||
procedure TLazReaderIcon.InternalRead(Stream: TStream; Img: TFPCustomImage);
|
||||
var
|
||||
CurrentDirEntry, BestDirEntry: TIconDirEntry;
|
||||
Row, Column, i: Integer;
|
||||
CurrentDirEntry, BestDirEntry, IconDir: PIconDirEntry;
|
||||
i: Integer;
|
||||
Bitmap: TBitmap;
|
||||
begin
|
||||
{ For the time being, read the largest and/or most colourful icon }
|
||||
Stream.Read(BestDirEntry, Sizeof(BestDirEntry));
|
||||
CurrentDirEntry := BestDirEntry;
|
||||
for i := 2 to FnIcons do begin
|
||||
Stream.Read(CurrentDirEntry, Sizeof(CurrentDirEntry));
|
||||
if ((CurrentDirEntry.bWidth > BestDirEntry.bWidth)
|
||||
and (CurrentDirEntry.bHeight > BestDirEntry.bHeight))
|
||||
or ((CurrentDirEntry.bWidth = BestDirEntry.bWidth)
|
||||
and (CurrentDirEntry.bHeight = BestDirEntry.bHeight)
|
||||
and (CurrentDirEntry.dwBytesInRes > BestDirEntry.dwBytesInRes)) then
|
||||
BestDirEntry := CurrentDirEntry;
|
||||
end;
|
||||
Stream.Position := FnStartPos + BestDirEntry.dwImageOffset;
|
||||
Stream.Read(BFI,SizeOf(BFI));
|
||||
BFI.biHeight := BFI.biHeight div 2; { Height field is doubled, to (sort of) accomodate mask }
|
||||
InternalReadBody(Stream, Img); { Now read standard bitmap }
|
||||
{ Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header }
|
||||
if BFI.biBitCount < 32 then begin
|
||||
ReadSize:=((Img.Width + 31) div 32) shl 2;
|
||||
SetupRead(2,Img.Width,Stream,False);
|
||||
GetMem(IconDir, FnIcons*Sizeof(TIconDirEntry));
|
||||
try
|
||||
for Row:=Img.Height-1 downto 0 do begin
|
||||
ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
|
||||
for Column:=0 to Img.Width-1 do
|
||||
if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
|
||||
img.colors[Column,Row]:=colTransparent
|
||||
Stream.Read(IconDir^, FnIcons*Sizeof(TIconDirEntry));
|
||||
BestDirEntry := IconDir;
|
||||
CurrentDirEntry := IconDir+1;
|
||||
{ First locate largest and/or most colourful icon as the default image }
|
||||
for i := 2 to FnIcons do begin
|
||||
if ((CurrentDirEntry^.bWidth > BestDirEntry^.bWidth)
|
||||
and (CurrentDirEntry^.bHeight > BestDirEntry^.bHeight))
|
||||
or ((CurrentDirEntry^.bWidth = BestDirEntry^.bWidth)
|
||||
and (CurrentDirEntry^.bHeight = BestDirEntry^.bHeight)
|
||||
and (CurrentDirEntry^.dwBytesInRes > BestDirEntry^.dwBytesInRes)) then
|
||||
BestDirEntry := CurrentDirEntry;
|
||||
Inc(CurrentDirEntry);
|
||||
end;
|
||||
if Assigned(Icon) then begin
|
||||
CurrentDirEntry := IconDir;
|
||||
for i := 1 to FnIcons do begin
|
||||
Stream.Position := FnStartPos + CurrentDirEntry^.dwImageOffset;
|
||||
if CurrentDirEntry = BestDirEntry then
|
||||
inherited InternalRead(Stream, Img)
|
||||
else begin
|
||||
Bitmap := TBitmap.Create;
|
||||
try
|
||||
Bitmap.ReadStreamWithFPImage(Stream, False, 0, TLazReaderPartIcon);
|
||||
except
|
||||
Bitmap.Free;
|
||||
raise;
|
||||
end;
|
||||
TIcon(Icon).AddBitmap(Bitmap);
|
||||
end;
|
||||
Inc(CurrentDirEntry);
|
||||
end;
|
||||
end else begin
|
||||
Stream.Position := FnStartPos + BestDirEntry^.dwImageOffset;
|
||||
inherited InternalRead(Stream, Img);
|
||||
{ Finally skip remaining icons }
|
||||
Stream.Position := FnStartPos + CurrentDirEntry^.dwImageOffset + CurrentDirEntry^.dwBytesInRes;
|
||||
end;
|
||||
finally
|
||||
FreeBufs;
|
||||
FreeMem(IconDir);
|
||||
end;
|
||||
end;
|
||||
{ Finally skip remaining icons }
|
||||
Stream.Position := FnStartPos + BestDirEntry.dwImageOffset + BestDirEntry.dwBytesInRes;
|
||||
end;
|
||||
|
||||
function TLazReaderIcon.InternalCheck(Stream: TStream): boolean;
|
||||
var
|
||||
|
||||
Loading…
Reference in New Issue
Block a user