📄 ietgafil.pas
字号:
XBitmap: TIEBitmap;
qt: TIEQuantizer;
nullpr: TProgressRec;
//
procedure TGAWriteHeader;
begin
TGAHead.IdentSize := Length(IOParams.TGA_Descriptor) + 1;
TGAHead.Bits := DestBitsPerPixel;
TGAHead.Descriptor := 0;
case DestBitsPerPixel of
1:
begin
// bilevel image
TGAHead.ColorMaptype := 0;
if IOParams.TGA_Compressed then
TGAHead.Imagetype := 11
else
TGAHead.Imagetype := 3;
TGAHead.ColorMapStart := 0;
TGAHead.ColorMapLength := 0;
TGAHead.ColorMapBits := 0;
end;
4, 8:
begin
if (DestBitsPerPixel = 8) and IOParams.TGA_GrayLevel then
begin
// gray scaled image
TGAHead.ColorMaptype := 0;
if IOParams.TGA_Compressed then
TGAHead.Imagetype := 11
else
TGAHead.Imagetype := 3;
TGAHead.ColorMapStart := 0;
TGAHead.ColorMapLength := 1 shl DestBitsPerPixel;
TGAHead.ColorMapBits := 24;
end
else
begin
// colormapped image
TGAHead.ColorMaptype := 1;
if IOParams.TGA_Compressed then
TGAHead.Imagetype := 9
else
TGAHead.Imagetype := 1;
TGAHead.ColorMapStart := 0;
TGAHead.ColorMapLength := 1 shl DestBitsPerPixel;
TGAHead.ColorMapBits := 24;
end;
end;
24:
begin
// true color image
TGAHead.ColorMaptype := 0;
if IOParams.TGA_Compressed then
TGAHead.Imagetype := 10
else
TGAHead.Imagetype := 2;
TGAHead.ColorMapStart := 0;
TGAHead.ColorMapLength := 0;
TGAHead.ColorMapBits := 0;
end;
32:
begin
// true color image with alpha (AlphaChannel must be valid and not empty)
TGAHead.ColorMaptype := 0;
if IOParams.TGA_Compressed then
TGAHead.Imagetype := 10
else
TGAHead.Imagetype := 2;
TGAHead.ColorMapStart := 0;
TGAHead.ColorMapLength := 0;
TGAHead.ColorMapBits := 0;
TGAHead.Descriptor := TGAHead.Descriptor or $8; // alpha channel with 8 bit
end;
end;
TGAHead.XStart := IOParams.TGA_XPos;
TGAHead.YStart := IOParams.TGA_YPos;
TGAHead.Width := OutputWidth;
TGAHead.Height := OutputHeight;
TGAHead.Descriptor := TGAHead.Descriptor or $20; // isn't IOParams.TGA_Descriptor!!
SafeStreamWrite(Stream, Progress.Aborting^, TGAHead, Sizeof(TGAHead));
SafeStreamWrite(Stream, Progress.Aborting^, pchar(IOParams.TGA_Descriptor)^, Length(IOParams.TGA_Descriptor) + 1);
if TGAHead.ColorMaptype = 1 then
SafeStreamWrite(Stream, Progress.Aborting^, rc^.Palette256[0], (1 shl DestBitsPerPixel) * 3);
end;
//
// convert to gray TempArrayDBIG (TBYTEROW)
// only for 8bpp
procedure TGAConvertToGray;
var
i: integer;
begin
for i := 0 to OutputWidth - 1 do
with rc^, Palette256[TempArrayDBIG^[i]] do
TempArrayDBIG^[i] := _RGBToGray(CreateRGB(r, g, b));
end;
//
// compress TempArrayDBIG (TBYTEROW) and saves it in CompRow and then in the stream
// implemented only for 8 and 24 bit
procedure TGACompress;
var
p, bwidth: integer;
l8: byte;
l24: TRGB;
l: byte;
warr: pbyte;
begin
with rc^ do
begin
warr := pbyte(@CompRow[0]);
p := 0;
case DestBitsPerPixel of
8: // encode 8 bit row (1 byte)
begin
bwidth := OutputWidth;
repeat
l8 := TempArrayDBIG^[p];
inc(p);
l := 1;
while (p < bwidth) and (l8 = TempArrayDBIG^[p]) and (l < 128) do
begin
inc(p);
inc(l);
end;
if l > 1 then
begin
// encode as run-length packet
warr^ := $80 or (l - 1);
inc(warr);
warr^ := l8;
inc(warr);
end
else
begin
// encode as raw packet
dec(p);
l := 0;
while (p < bwidth - 1) and (TempArrayDBIG^[p] <> TemparrayDBIG^[p + 1]) and (l < 127) do
begin
inc(p);
inc(l);
end;
if p = bwidth - 1 then
begin
inc(p);
inc(l);
end;
warr^ := l - 1;
inc(warr);
CopyMemory(warr, @TempArrayDBIG^[p - l], l);
inc(warr, l);
end;
until p >= bwidth;
end;
24: // encode 24 bit row (3 byte)
begin
bwidth := OutputWidth * 3;
repeat
l24 := PRGB(@TempArrayDBIG^[p])^;
inc(p, 3);
l := 1;
while (p < bwidth) and equalrgb(l24, PRGB(@TempArrayDBIG^[p])^) and (l < 128) do
begin
inc(p, 3);
inc(l);
end;
if l > 1 then
begin
// encode as run-length packet
warr^ := $80 or (l - 1);
inc(warr);
PRGB(warr)^ := l24;
inc(warr, 3);
end
else
begin
// encode as raw packet
dec(p, 3);
l := 0;
while (p < bwidth - 3) and (not equalrgb(PRGB(@TempArrayDBIG^[p])^, PRGB(@TemparrayDBIG^[p + 3])^)) and (l < 127) do
begin
inc(p, 3);
inc(l);
end;
if p = bwidth - 3 then
begin
inc(p, 3);
inc(l);
end;
warr^ := l - 1;
inc(warr);
CopyMemory(warr, @TempArrayDBIG^[p - l * 3], l * 3);
inc(warr, l * 3);
end;
until p >= bwidth;
end;
end;
SafeStreamWrite(Stream, Progress.Aborting^, CompRow^[0], integer(warr) - integer(@CompRow[0]));
end;
end;
//
procedure TGAWriteBody;
var
i, l, x: integer;
oarr, px, al, sp: pbyte;
begin
with rc^ do
begin
i := 0;
Progress.per1 := 100 / OutputHeight;
Progress.val := 0;
if DestBitsPerPixel = 32 then
getmem(oarr, XBitmap.Width * 4)
else
oarr := nil;
repeat
TempArrayD := XBitMap.ScanLine[i];
if DestBitsPerPixel = 32 then
l := _ConvertXBitsToYBits(TempArrayD^, TempArrayDBIG^, OrigBitsPerPixel, 24, OutputWidth, Palette256, qt)
else
l := _ConvertXBitsToYBits(TempArrayD^, TempArrayDBIG^, OrigBitsPerPixel, DestBitsPerPixel, OutputWidth, Palette256, qt);
if IOParams.TGA_GrayLevel and (DestBitsPerPixel = 8) then
TGAConvertToGray;
if IOParams.TGA_Compressed then
TGACompress
else
begin
if DestBitsPerPixel = 32 then
begin
// add and save alpha channel
al := AlphaChannel.Scanline[i];
px := oarr;
sp := pbyte(TempArrayDBIG);
for x := 0 to XBitmap.Width - 1 do
begin
px^ := sp^;
inc(px);
inc(sp);
px^ := sp^;
inc(px);
inc(sp);
px^ := sp^;
inc(px);
inc(sp);
px^ := al^;
inc(px);
inc(al);
end;
SafeStreamWrite(Stream, Progress.Aborting^, oarr^, 4 * XBitmap.Width);
end
else
SafeStreamWrite(Stream, Progress.Aborting^, TempArrayDBIG^[0], l);
end;
inc(i);
with Progress do
begin
inc(val);
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * val));
end;
until (i >= OutputHeight);
if DestBitsPerPixel = 32 then
freemem(oarr);
end;
end;
//
procedure TGAWriteExtension;
var
ms: word;
begin
with rc^, Extension do
begin
zeromemory(@Extension, sizeof(TGAExtension));
strcopy(AuthorName, pchar(IOParams.TGA_Author));
strcopy(JobName, pchar(IOParams.TGA_ImageName));
DecodeDate(IOParams.TGA_Date, DateTime[2], DateTime[0], DateTime[1]);
DecodeTime(IOParams.TGA_Date, DateTime[3], DateTime[4], DateTime[5], ms);
KeyColor[0] := 0;
KeyColor[1] := IOParams.TGA_Background.r;
KeyColor[2] := IOParams.TGA_Background.g;
KeyColor[3] := IOParams.TGA_Background.b;
AspectRatio[0] := trunc(IOParams.TGA_AspectRatio) * 10000;
AspectRatio[1] := 10000;
Gamma[0] := trunc(IOParams.TGA_Gamma) * 10000;
Gamma[1] := 10000;
SafeStreamWrite(Stream, Progress.Aborting^, Extension, sizeof(TGAExtension));
if DestBitsPerPixel = 32 then
AttributesType := 0;
end;
end;
//
procedure TGAWriteFooter;
begin
with rc^ do
begin
Footer.Signature := 'TRUEVISION-XFILE.' + chr(0);
Footer.DeveloperDir := 0;
Footer.ExtensionArea := sbase + Stream.Position;
TGAWriteExtension;
SafeStreamWrite(Stream, Progress.Aborting^, Footer, sizeof(TGAFooter));
end;
end;
//
var
rgb1, rgb2: TRGB;
begin
if (Bitmap.PixelFormat <> ie24RGB) and (Bitmap.PixelFormat <> ie1g) then
exit;
with nullpr do
begin
Aborting := Progress.Aborting;
fOnProgress := nil;
Sender := nil;
end;
XBitmap := Bitmap;
qt := nil;
new(rc);
zeromemory(rc, sizeof(TRC));
with rc^ do
begin
// Write TARGA Stream.
sbase := Stream.Position;
Index1 := 0;
Index2 := 0;
if Bitmap.PixelFormat = ie24RGB then
OrigBitsPerPixel := 24
else
OrigBitsPerPixel := 1;
if IOParams.SamplesPerPixel = 1 then
begin
case IOParams.BitsPerSample of
1:
begin
if OrigBitsPerPixel = 24 then
begin
XBitmap := _ConvertTo1bitEx(Bitmap, rgb1, rgb2);
if XBitmap = nil then
begin
// impossibile convertire a 1 bit, converti in ordered dither
XBitmap := TIEBitmap.Create;
XBitmap.Assign(Bitmap);
XBitmap.PixelFormat := ie1g;
end;
OrigBitsPerPixel := 1;
end;
DestBitsPerPixel := 1;
Palette256[0] := CreateRGB(0, 0, 0);
Palette256[1] := CreateRGB(255, 255, 255);
IOParams.TGA_Compressed := false;
end;
4:
begin
if OrigBitsPerPixel = 24 then
begin
IOParams.fColorMapCount := 16;
getmem(IOParams.fColorMap, 16 * 3);
qt := TIEQuantizer.Create(Bitmap, IOParams.ColorMap^, 16, -1, 0);
copymemory(@Palette256[0], IOparams.ColorMap, 16 * 3);
end;
DestBitsPerPixel := 4;
IOParams.TGA_Compressed := false;
end;
8:
begin
if OrigBitsPerPixel = 24 then
begin
IOParams.fColorMapCount := 256;
getmem(IOParams.fColorMap, 256 * 3);
qt := TIEQuantizer.Create(Bitmap, IOParams.ColorMap^, 256, -1, 0);
copymemory(@Palette256[0], IOparams.ColorMap, 256 * 3);
end;
DestBitsPerPixel := 8;
end;
end;
end
else
begin
if assigned(AlphaChannel) and (not AlphaChannel.Full) then
begin
DestBitsPerPixel := 32;
IOParams.TGA_Compressed := false; // alpha+compression not supported
end
else
DestBitsPerPixel := 24;
end;
OutputWidth := XBitmap.Width;
OutputHeight := XBitmap.Height;
GetMem(NewLine, OutputWidth * 3);
GetMem(TempArrayDBig, OutputWidth * 3);
if IOParams.TGA_Compressed then
getmem(CompRow, OutputWidth * 3 * 3);
TGAWriteHeader;
TGAWriteBody;
TGAWriteFooter;
FreeMem(TempArrayDBig);
FreeMem(NewLine);
if IOParams.TGA_Compressed then
freemem(CompRow);
end;
dispose(rc);
if XBitmap <> Bitmap then
FreeAndNil(XBitmap);
if assigned(qt) then
FreeAndNil(qt);
end;
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -