paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 07:46:00 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ Added support for 32-bit writing. Standard is still 24 bit.

Browse Source
This commit is contained in:
michael 2004-02-20 23:52:49 +00:00
parent 45aef562dd
commit b3f0b0984a
1 changed files with 103 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

189
fcl/image/fpwritebmp.pp
View File

@ -24,13 +24,15 @@ uses FPImage, classes, sysutils;
type type
TFPWriterBMP = class (TFPCustomImageWriter) TFPWriterBMP = class (TFPCustomImageWriter)
private private
BytesPerPixel:Integer; FBytesPerPixel : Byte;
procedure SetColorSize (AValue : byte); procedure SetColorSize (AValue : Byte);
protected protected
procedure InternalWrite (Stream:TStream; Img:TFPCustomImage); override; function SaveHeader(Stream:TStream; Img: TFPCustomImage):boolean; virtual;
public procedure InternalWrite (Stream:TStream; Img: TFPCustomImage); override;
constructor Create; override; public
constructor Create; override;
Property BytesPerPixel : Byte Read FBytesPerPixel Write SetColorSize;
end; end;
@ -38,103 +40,118 @@ implementation
uses BMPcomn; uses BMPcomn;
Function FPColorToRGB(Const Color : TFPColor) : TColorRGB;
begin
With Result,Color do
begin
R:=(Red and $FF00) shr 8;
G:=(Green and $FF00) shr 8;
B:=(Blue and $FF00) shr 8;
end;
end;
Function FPColorToRGBA(Const Color : TFPColor) : TColorRGBA;
begin
With Result,Color do
begin
R:=(Red and $FF00) shr 8;
G:=(Green and $FF00) shr 8;
B:=(Blue and $FF00) shr 8;
A:=(Alpha and $FF00) shr 8;
end;
end;
constructor TFPWriterBMP.create; constructor TFPWriterBMP.create;
begin begin
inherited create; inherited create;
BytesPerPixel := 3 FBytesPerPixel:=3;
end; end;
procedure TFPWriterBMP.SetColorSize (AValue : byte); procedure TFPWriterBMP.SetColorSize (AValue : byte);
begin begin
if AValue >= 3 if (AValue>4) then
then AValue:=4;
BytesPerPixel := 3 if (AValue<1) then
else if AValue = 0 AValue:=1;
then FBytesPerPixel:=AValue;
BytesPerPixel := 1 end;
else
BytesPerPixel := AValue; function TFPWriterBMP.SaveHeader(Stream:TStream; Img : TFPCustomImage):boolean;
var
BFH:TBitMapFileHeader;
BFI:TBitMapInfoHeader;
begin
Result:=False;
with BFI do
begin
Size:=sizeof(TBitMapInfoHeader);
Width:=Img.Width;
Height:=Img.Height;
Planes:=1;
BitCount:=BytesPerPixel SHL 3;
Compression:=0;
SizeImage:=Width*Height;
XPelsPerMeter:=100;
YPelsPerMeter:=100;
ClrUsed:=0; // No palette yet.
ClrImportant:=0;
end;
with BFH do
begin
bfType:=BMmagic;//'BM'
bfOffset:=sizeof(TBitMapFileHeader)+sizeof(TBitMapInfoHeader);
bfReserved:=0;
bfSize:=bfOffset+BFI.SizeImage*BytesPerPixel;
end;
Stream.seek(0,soFromBeginning);
Stream.Write(bfh,sizeof(TBitMapFileHeader));
Stream.Write(bfi,sizeof(TBitMapInfoHeader));
Result:=true;
end; end;
procedure TFPWriterBMP.InternalWrite (Stream:TStream; Img:TFPCustomImage); procedure TFPWriterBMP.InternalWrite (Stream:TStream; Img:TFPCustomImage);
function SaveHeader(stream:TStream):boolean;
var var
BFH:TBitMapFileHeader; Row,Col,nBpLine,WriteSize:Integer;
BFI:TBitMapInfoHeader; aLine: PByte;
begin S : Integer;
SaveHeader := false;
with BFI do begin
begin If Not (BytesPerPixel in [3,4]) then
Size:=sizeof(TBitMapInfoHeader); Raise FPImageException.Create('Only 24 or 32 bit images are currently supported.');
Width:=Img.Width; SaveHeader(Stream,Img);
Height:=Img.Height; nBpLine:=Img.Width*BytesPerPixel;
Planes:=1; WriteSize:=(nBpLine+3) AND $FFFFFFFC; //BMP needs evry line 4Bytes aligned
BitCount:=BytesPerPixel SHL 3; GetMem(aLine,(Img.Width+1)*BytesPerPixel);//3 extra byte for BMP 4Bytes alignement.
Compression:=0; Try
SizeImage:=Width*Height; for Row:=Img.Height-1 downto 0 do
XPelsPerMeter:=100;
YPelsPerMeter:=100;
ClrUsed:=0;
ClrImportant:=0;
end;
with BFH do
begin
bfType:=BMmagic;//'BM'
bfOffset:=sizeof(TBitMapFileHeader)+sizeof(TBitMapInfoHeader);
bfReserved:=0;
bfSize:=bfOffset+BFI.SizeImage*BytesPerPixel;
end;
stream.seek(0,soFromBeginning);
stream.Write(bfh,sizeof(TBitMapFileHeader));
stream.Write(bfi,sizeof(TBitMapInfoHeader));
if(bfi.bitCount = 8)
then
begin
// stream.Write(Palet, bfh.bfOffset - 54);
end;
SaveHeader := true;
end;
var
Row,Coulumn,nBpLine,WriteSize:Integer;
aColor:TFPcolor;
{$IFDEF UseDynArray}
aLine:ARRAY OF TColorRGB;
{$ELSE UseDynArray}
aLine:^TColorRGB;
{$ENDIF UseDynArray}
begin
SaveHeader(Stream);
nBpLine:=Img.Width*SizeOf(TColorRGB);
WriteSize:=(nBpLine+3)AND $FFFFFFFC;//BMP needs evry line 4Bytes aligned
{$IFDEF UseDynArray}
SetLength(aLine,Img.Width+1);//3 extra byte for BMP 4Bytes alignement.
{$ELSE UseDynArray}
GetMem(aLine,(Img.Width+1)*SizeOf(TColorRGB));//3 extra byte for BMP 4Bytes alignement.
{$ENDIF UseDynArray}
for Row:=img.Height-1 downto 0 do
begin begin
for Coulumn:=0 to img.Width-1 do Case BytesPerPixel of
with aLine[Coulumn],aColor do 3 : for Col:=0 to img.Width-1 do
begin PColorRGB(aLine)[Col]:=FPColorToRGB(img.colors[Col,Row]);
aColor := img.colors[Coulumn,Row]; 4 : for Col:=0 to img.Width-1 do
{Use only the high byte to convert the color} PColorRGBA(aLine)[Col]:=FPColorToRGBA(img.colors[Col,Row]);
R:=(Red and $FF00) shr 8; end;
G:=(Green and $FF00) shr 8; Stream.Write(aLine[0],WriteSize);
B:=(Blue and $FF00) shr 8;
end;
Stream.Write(aLine{$IFNDEF UseDynArray}^{$ENDIF UseDynArray},WriteSize);
end; end;
{$IFNDEF UseDynArray} Finally
FreeMem(aLine,(Img.Width+1)*SizeOf(TColorRGB)); FreeMem(aLine);
{$ENDIF UseDynArray} end;
end; end;
initialization initialization
ImageHandlers.RegisterImageWriter ('BMP Format', 'bmp', TFPWriterBMP); ImageHandlers.RegisterImageWriter ('BMP Format', 'bmp', TFPWriterBMP);
end. end.
{ {
$Log$ $Log$
Revision 1.5 2003-09-09 11:28:23 mazen Revision 1.6 2004-02-20 23:52:49 michael
+ Added support for 32-bit writing. Standard is still 24 bit.
Revision 1.5 2003/09/09 11:28:23 mazen
* fixing copyright section in the file header * fixing copyright section in the file header
Revision 1.4 2003/09/08 14:08:48 mazen Revision 1.4 2003/09/08 14:08:48 mazen