mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-22 16:19:36 +02:00
added basic TIcon reading from Colin
git-svn-id: trunk@5390 -
This commit is contained in:
mattias
parent
26b4223134
commit
ffe9052073
@ -903,7 +903,8 @@ type
|
||||
TBitmapNativeType = (
|
||||
bnNone,
|
||||
bnWinBitmap,
|
||||
bnXPixmap
|
||||
bnXPixmap,
|
||||
bnIcon
|
||||
);
|
||||
TBitmapNativeTypes = set of TBitmapNativeType;
|
||||
|
||||
@ -1109,9 +1110,11 @@ type
|
||||
{ TIcon }
|
||||
{
|
||||
TIcon reads and writes .ICO file format.
|
||||
! Currently it is only a TBitmap !
|
||||
! Currently it is almost a TBitmap !
|
||||
}
|
||||
TIcon = class(TBitmap)
|
||||
protected
|
||||
procedure ReadData(Stream: TStream); override;
|
||||
end;
|
||||
|
||||
|
||||
@ -1175,6 +1178,7 @@ var
|
||||
function TestStreamBitmapNativeType(const AStream: TStream): TBitmapNativeType;
|
||||
function TestStreamIsBMP(const AStream: TStream): boolean;
|
||||
function TestStreamIsXPM(const AStream: TStream): boolean;
|
||||
function TestStreamIsIcon(const AStream: TStream): boolean;
|
||||
|
||||
function XPMToPPChar(const XPM: string): PPChar;
|
||||
function LazResourceXPMToPPChar(const ResourceName: string): PPChar;
|
||||
@ -1213,7 +1217,6 @@ const
|
||||
***************************************************************************)
|
||||
implementation
|
||||
|
||||
|
||||
function SendIntfMessage(LM_Message : integer; Sender : TObject;
|
||||
Data : pointer) : integer;
|
||||
begin
|
||||
@ -1583,6 +1586,35 @@ begin
|
||||
Result:='image/'+DefaultFileExt;
|
||||
end;
|
||||
|
||||
{ TIcon }
|
||||
|
||||
function TestStreamIsIcon(const AStream: TStream): boolean;
|
||||
var
|
||||
Signature: array[0..3] of char;
|
||||
ReadSize: Integer;
|
||||
OldPosition: TStreamSeekType;
|
||||
begin
|
||||
OldPosition:=AStream.Position;
|
||||
ReadSize:=AStream.Read(Signature, SizeOf(Signature));
|
||||
Result:=(ReadSize=SizeOf(Signature)) and (Signature=#0#0#1#0);
|
||||
AStream.Position:=OldPosition;
|
||||
end;
|
||||
|
||||
procedure TIcon.ReadData(Stream: TStream);
|
||||
var
|
||||
Size: longint;
|
||||
Position: TStreamSeekType;
|
||||
begin
|
||||
Position := Stream.Position;
|
||||
Stream.Read(Size, SizeOf(Size));
|
||||
if Size = $10000 then begin // Icon starts 00 00 01 00
|
||||
// Assume Icon - stream without explicit size
|
||||
Stream.Position := Position;
|
||||
ReadStream(Stream, false, Size);
|
||||
end else
|
||||
ReadStream(Stream, true, Size);
|
||||
end;
|
||||
|
||||
initialization
|
||||
PicClipboardFormats:=nil;
|
||||
PicFileFormats:=nil;
|
||||
@ -1604,6 +1636,9 @@ end.
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.132 2004/04/10 00:11:16 mattias
|
||||
added basic TIcon reading from Colin
|
||||
|
||||
Revision 1.131 2004/04/03 16:47:46 mattias
|
||||
implemented converting gdkbitmap to RawImage mask
|
||||
|
||||
|
||||
@ -24,6 +24,8 @@ begin
|
||||
Result:=bnWinBitmap
|
||||
else if TestStreamIsXPM(AStream) then
|
||||
Result:=bnXPixmap
|
||||
else if TestStreamIsIcon(AStream) then
|
||||
Result := bnIcon
|
||||
else
|
||||
Result:=bnNone;
|
||||
end;
|
||||
@ -497,6 +499,7 @@ begin
|
||||
case StreamType of
|
||||
bnWinBitmap: ReaderClass:=TLazReaderBMP;
|
||||
bnXPixmap: ReaderClass:=TLazReaderXPM;
|
||||
bnIcon: ReaderClass:=TLazReaderIcon;
|
||||
else
|
||||
RaiseInvalidBitmapHeader;
|
||||
end;
|
||||
@ -1193,6 +1196,9 @@ end;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.84 2004/04/10 00:11:16 mattias
|
||||
added basic TIcon reading from Colin
|
||||
|
||||
Revision 1.83 2004/04/05 11:41:05 mattias
|
||||
fixed retrieving gdkbitmaps LineEnding=rileDWordBoundary
|
||||
|
||||
|
||||
@ -330,17 +330,30 @@ type
|
||||
LineBuf: PByte; // Buffer for 1 scanline. Can be Byte, Word, TColorRGB or TColorRGBA
|
||||
|
||||
// SetupRead will allocate the needed buffers, and read the colormap if needed.
|
||||
procedure SetupRead(nPalette, nRowBits: Integer; Stream: TStream); virtual;
|
||||
procedure SetupRead(nPalette, nRowBits: Integer; Stream: TStream;
|
||||
ReadPalette: Boolean); virtual;
|
||||
procedure ReadScanLine(Row: Integer; Stream: TStream); virtual;
|
||||
procedure WriteScanLine(Row: Integer; Img: TFPCustomImage); virtual;
|
||||
// required by TFPCustomImageReader
|
||||
procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
|
||||
procedure InternalReadBody(Stream: TStream; Img: TFPCustomImage);
|
||||
function InternalCheck(Stream: TStream) : boolean; override;
|
||||
public
|
||||
constructor Create; override;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
{ TLazReaderIcon }
|
||||
{ This is a FPImage writer for icon images. }
|
||||
TLazReaderIcon = class (TLazReaderBMP)
|
||||
private
|
||||
FnIcons: Integer;
|
||||
FnStartPos: TStreamSeekType;
|
||||
protected
|
||||
// required by TFPCustomImageReader
|
||||
procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
|
||||
function InternalCheck(Stream: TStream) : boolean; override;
|
||||
end;
|
||||
|
||||
function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
|
||||
procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
|
||||
@ -2924,7 +2937,8 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TLazReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream: TStream);
|
||||
procedure TLazReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream: TStream;
|
||||
ReadPalette: Boolean);
|
||||
{$ifdef VER1_0}
|
||||
type
|
||||
tcolinfo = ARRAY [0..0] OF TColorBmpRGBA;
|
||||
@ -2942,20 +2956,24 @@ begin
|
||||
GetMem(FPalette, nPalette*SizeOf(TFPColor));
|
||||
{$ifdef VER1_0}
|
||||
GetMem(ColInfo, nPalette*Sizeof(TColorBmpRGBA));
|
||||
if BFI.biClrUsed>0 then
|
||||
Stream.Read(ColInfo^[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
|
||||
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]);
|
||||
if ReadPalette then begin
|
||||
if BFI.biClrUsed>0 then
|
||||
Stream.Read(ColInfo^[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
|
||||
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]);
|
||||
end;
|
||||
{$else}
|
||||
SetLength(ColInfo, nPalette);
|
||||
if BFI.biClrUsed>0 then
|
||||
Stream.Read(ColInfo[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
|
||||
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]);
|
||||
if ReadPalette then begin
|
||||
if BFI.biClrUsed>0 then
|
||||
Stream.Read(ColInfo[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
|
||||
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]);
|
||||
end;
|
||||
{$endif}
|
||||
end
|
||||
else if BFI.biClrUsed>0 then { Skip palette }
|
||||
@ -3006,10 +3024,15 @@ begin
|
||||
end;
|
||||
|
||||
procedure TLazReaderBMP.InternalRead(Stream: TStream; Img: TFPCustomImage);
|
||||
begin
|
||||
Stream.Read(BFI,SizeOf(BFI));
|
||||
InternalReadBody(Stream, Img);
|
||||
end;
|
||||
|
||||
procedure TLazReaderBMP.InternalReadBody(Stream: TStream; Img: TFPCustomImage);
|
||||
Var
|
||||
Row : Integer;
|
||||
begin
|
||||
Stream.Read(BFI,SizeOf(BFI));
|
||||
{ This will move past any junk after the BFI header }
|
||||
Stream.Position:=Stream.Position-TStreamSeekType(SizeOf(BFI)-BFI.biSize);
|
||||
with BFI do
|
||||
@ -3021,17 +3044,17 @@ begin
|
||||
end;
|
||||
Case BFI.biBitCount of
|
||||
1 : { Monochrome }
|
||||
SetupRead(2,Img.Width,Stream);
|
||||
SetupRead(2,Img.Width,Stream,true);
|
||||
4 :
|
||||
SetupRead(16,Img.Width*4,Stream);
|
||||
SetupRead(16,Img.Width*4,Stream,true);
|
||||
8 :
|
||||
SetupRead(256,Img.Width*8,Stream);
|
||||
SetupRead(256,Img.Width*8,Stream,true);
|
||||
16 :
|
||||
SetupRead(0,Img.Width*8*2,Stream);
|
||||
SetupRead(0,Img.Width*8*2,Stream,true);
|
||||
24:
|
||||
SetupRead(0,Img.Width*8*3,Stream);
|
||||
SetupRead(0,Img.Width*8*3,Stream,true);
|
||||
32:
|
||||
SetupRead(0,Img.Width*8*4,Stream);
|
||||
SetupRead(0,Img.Width*8*4,Stream,true);
|
||||
end;
|
||||
Try
|
||||
for Row:=Img.Height-1 downto 0 do
|
||||
@ -3115,6 +3138,78 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TLazReaderIcon }
|
||||
|
||||
type
|
||||
TIconHeader = packed record
|
||||
idReserved: Word; {0}
|
||||
idType: Word; {1}
|
||||
idCount: Word; {number of icons in file}
|
||||
end;
|
||||
|
||||
TIconDirEntry = packed record
|
||||
bWidth: Byte; {ie: 16 or 32}
|
||||
bHeight: Byte; {ie: 16 or 32}
|
||||
bColorCount: Byte; {number of entires in pallette table below}
|
||||
bReserved: Byte; { not used = 0}
|
||||
wPlanes: Word; { not used = 0}
|
||||
wBitCount: Word; { not used = 0}
|
||||
dwBytesInRes: Longint; {total number bytes in images including pallette data
|
||||
XOR, AND and bitmap info header}
|
||||
dwImageOffset: Longint; {pos of image as offset from the beginning of file}
|
||||
end;
|
||||
|
||||
procedure TLazReaderIcon.InternalRead(Stream: TStream; Img: TFPCustomImage);
|
||||
var
|
||||
CurrentDirEntry, BestDirEntry: TIconDirEntry;
|
||||
Row, Column, i: Integer;
|
||||
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);
|
||||
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;
|
||||
{ Finally skip remaining icons }
|
||||
Stream.Position := FnStartPos + BestDirEntry.dwImageOffset + BestDirEntry.dwBytesInRes;
|
||||
end;
|
||||
|
||||
function TLazReaderIcon.InternalCheck(Stream: TStream): boolean;
|
||||
var
|
||||
IconHeader: TIconHeader;
|
||||
begin
|
||||
FnStartPos := Stream.Position;
|
||||
Stream.Read(IconHeader,SizeOf(IconHeader));
|
||||
With IconHeader do
|
||||
Result := (idReserved=0) and (idType=1);
|
||||
FnIcons := IconHeader.idCount;
|
||||
end;
|
||||
|
||||
initialization
|
||||
InternalInit;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user