pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity
Files
5add7d51a1195ff9a5377abc60c92afb20085cb6
kolmck/Addons/KOLTGA.pas

1061 lines
36 KiB
ObjectPascal
Raw Normal View History

addons update git-svn-id: https://svn.code.sf.net/p/kolmck/code@67 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
2010-10-04 12:58:59 +00:00
unit KOLTGA;
/////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////
//// KOL TARGA translated for KOL by MrBrdo ////
//// I don't know who orignaly made this, but the ////
//// component was to be registered under A-Team. ////
/////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////
interface
uses
Windows, KOL, Messages;
{$I KOLDEF.INC}
{$WARNINGS OFF}
var
Color16to24: array[0..31] of Byte = (0, 8, 16, 24, 32, 40, 48, 56, 64, 72, 80, 88, 96, 104, 112,
120, 128, 136, 144, 152, 160, 168, 176, 184, 192, 200, 208,
216, 224, 232, 240, 248);
const
NO_COLORMAP_INCLUDED = 0;
COLORMAP_IS_INCLUDED = 1;
NO_IMAGEDATA_INCLUDED = 0;
COLORMAPPED_IMAGE = 1;
TRUECOLOR_IMAGE = 2;
BLACKANDWHITE_IMAGE = 3;
RLE_COLORMAPPED_IMAGE = 9;
RLE_TRUECOLOR_IMAGE = 10;
RLE_BLACKANDWHITE_IMAGE = 11;
CF_TARGA = 20;
type
PByteArray = ^TByteArray;
TByteArray = array[0..32767] of Byte;
TTargaID = packed record
Length: Byte;
Text: PChar;
end;
TTargaColorMapSpec = packed record
FirstEntryIndex: Word;
ColorMapLength: Word;
ColorMapEntrySize: Byte;
end;
TTargaImageDescriptor = packed record
AlphaChannelBits: Byte;
Top: Boolean;
Left: Boolean;
end;
TTargaImageSpec = packed record
X: Word;
Y: Word;
Width: Word;
Height: Word;
PixelDepth: Byte;
ImageDescriptor: TTargaImageDescriptor;
end;
TRGBA = packed record
Red: Byte;
Green: Byte;
Blue: Byte;
Alpha: Byte;
end;
TColorMap = packed array[0..999] of TRGBA;
TTargaType = (ttNoImageData, ttColorMapedImage, ttTrueColorImage, ttBlackAndWhiteImage, ttRLEColorMapedImage,
ttRLETrueColorImage, ttRLEBlackAndWhiteImage);
TTargaViewType = (tvBitmap, tvAlphaChannel, tvUseAlphaChannel);
TTargaColorDepthType = (cd8bit, cd16bit, cd24bit, cd32bit);
TTargaClipboardType = (ctTarga, ctBitmap, ctAlphaChannel);
type
PTarga = ^TTarga;
TTarga = object(TObj)
private
FColorDepth: TTargaColorDepthType;
FColorMapType: Byte;
FColorMap: TColorMap;
FColorMapSpec: TTargaColorMapSpec;
FID: TTargaID;
FImageType: Byte;
FImageSpec: TTargaImageSpec;
FIncludeAlphaChannel: Boolean;
FTargaType: TTargaType;
FBitmap: PBitmap;
FAlphaChannel: PBitmap;
procedure SetBitmap(Value: PBitmap);
procedure SetAlphaChannel(Value: PBitmap);
function RLEDecompress(DataLength: Integer; var RLEBuffer: PChar; var Buffer: PChar): Integer;
function RLECompress(DataLength: Integer; var RLEBuffer: PChar; var Buffer: PChar): Integer;
protected
// function Equals(Graphic: TGraphic): Boolean; virtual;
function GetEmpty: Boolean; virtual;
function GetHeight: Integer; virtual;
// function GetPalette: HPALETTE; virtual;
// function GetTransparent: Boolean; virtual;
function GetWidth: Integer; virtual;
// procedure Progress(Sender: TObject; Stage: TProgressStage; PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
procedure SetHeight(Value: Integer); virtual;
// procedure SetPalette(Value: HPALETTE); virtual;
// procedure SetTransparent(Value: Boolean); virtual;
procedure SetWidth(Value: Integer); virtual;
public
// constructor Create; virtual;
procedure Draw(ACanvas: PCanvas; const Rect: TRect); virtual;
destructor Destroy; virtual;
procedure LoadFromResourceName(Instance: THandle; const ResName: String);
procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
procedure LoadFromFile(const FileName: string); virtual;
procedure LoadFromStream(Stream: PStream); virtual;
procedure SaveToFile(const FileName: string); virtual;
procedure SaveToStream(Stream: PStream); virtual;
procedure Assign(Source: PTarga); virtual;
property Bitmap: PBitmap read FBitmap write SetBitmap;
property AlphaChannel: PBitmap read FAlphaChannel write SetAlphaChannel;
property Empty: Boolean read GetEmpty;
end;
function NewTarga: PTarga;
implementation
function NewTarga: PTarga;
begin
New(Result,Create);
with Result^ do
begin
FBitmap := NewBitmap(0,0);
FBitmap.PixelFormat:=pf32bit;
FAlphaChannel:=NewBitmap(0,0);
FAlphaChannel.PixelFormat:=pf32bit;
end;
end;
destructor TTarga.Destroy;
begin
if Assigned(FBitmap) then
FBitmap.Free;
if Assigned(FAlphaChannel) then
FAlphaChannel.Free;
inherited Destroy;
end;
procedure TTarga.LoadFromFile(const FileName: string);
var fsOpen: PStream;
begin
fsOpen:=NewReadFileStream(FileName);
try
LoadFromStream(fsOpen);
finally
fsOpen.Free;
end;
end;
procedure TTarga.SaveToFile(const FileName: string);
var fsOpen: PStream;
begin
if not Assigned(FBitmap) then Exit;
if UpperCase(CopyTail(FileName,3))='.BMP' then
begin
FBitmap.SaveToFile(FileName);
end
else
begin
fsOpen:=NewWriteFileStream(FileName);
try
SaveToStream(fsOpen);
finally
fsOpen.Free;
end;
end;
end;
procedure TTarga.Draw(ACanvas: PCanvas; const Rect: TRect);
begin
StretchBlt(ACanvas.Handle, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
Rect.Bottom - Rect.Top, FBitmap.Canvas.Handle, 0, 0, FBitmap.Width, FBitmap.Height, ACanvas.ModeCopy);
end;
procedure TTarga.SetBitmap(Value: PBitmap);
begin
if FBitmap <> Value then
begin
FBitmap.Assign(Value);
end;
end;
procedure TTarga.SetAlphaChannel(Value: PBitmap);
begin
if FAlphaChannel <> Value then
begin
FAlphaChannel.Assign(Value);
end;
end;
function TTarga.GetEmpty: Boolean;
begin
Result := (FBitmap = nil) or FBitmap.Empty;
end;
function TTarga.GetHeight: Integer;
begin
Result:=FImageSpec.Height;
end;
function TTarga.GetWidth: Integer;
begin
Result:=FImageSpec.Width;
end;
procedure TTarga.SetHeight(Value: Integer);
begin
end;
procedure TTarga.SetWidth(Value: Integer);
begin
end;
procedure TTarga.Assign(Source: PTarga);
begin
FBitmap.Assign(Source^.FBitmap);
FAlphaChannel.Assign(Source^.FAlphaChannel);
end;
procedure TTarga.LoadFromResourceName(Instance: THandle; const ResName: String);
var
Stream: PStream;
begin
Stream := NewMemoryStream;
Resource2Stream(Stream, Instance, PChar(ResName), RT_RCDATA);
Stream.Seek(0, spBegin);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TTarga.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
Stream: PStream;
begin
Stream := NewMemoryStream;
Resource2Stream(Stream, Instance, MAKEINTRESOURCE( ResID ), RT_RCDATA);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TTarga.LoadFromStream(Stream: PStream);
var Buffer: PChar;
RLEBuffer: PChar;
i, j: Integer;
Color16: Word;
LineSize: Integer;
LineBuffer, AlphaBuffer: PByteArray;
tmp16: Word;
ReadLength: Integer;
procedure GetBAWImageType(IsRLE: Boolean);
var i, j: Integer;
begin
FColorDepth:=cd8bit;
FIncludeAlphaChannel:=False;
if IsRLE then FTargaType:=ttRLEBlackAndWhiteImage else FTargaType:=ttBlackAndWhiteImage;
if IsRLE then RLEBuffer:=AllocMem(LineSize*2);
for i:=0 to FImageSpec.Height-1 do
begin
if not FImageSpec.ImageDescriptor.Top and not FImageSpec.ImageDescriptor.Left then
LineBuffer:=FBitmap.ScanLine[FImageSpec.Height-(i+1)]
else LineBuffer:=FBitmap.ScanLine[i];
if IsRLE then
begin
ReadLength:=Stream.Read(RLEBuffer^,LineSize*2);
Stream.Position:=Stream.Position-ReadLength+RLEDecompress(FImageSpec.Width,RLEBuffer, Buffer);
end
else Stream.Read(Buffer^,LineSize);
for j:=0 to FImageSpec.Width-1 do
begin
LineBuffer[(j*4)]:=Ord(Buffer[j]);
LineBuffer[(j*4)+1]:=Ord(Buffer[j]);
LineBuffer[(j*4)+2]:=Ord(Buffer[j]);
end;
end;
end;
begin
Buffer:=AllocMem(18);
Stream.Read(Buffer^,18);
FID.Length:=Ord(Buffer[0]);
FColorMapType:=Ord(Buffer[1]);
FImageType:=Ord(Buffer[2]);
FColorMapSpec.FirstEntryIndex:=Ord(Buffer[3])+Ord(Buffer[4])*256;
FColorMapSpec.ColorMapLength:=Ord(Buffer[5])+Ord(Buffer[6])*256;
FColorMapSpec.ColorMapEntrySize:=Ord(Buffer[7]);
FImageSpec.X:=Ord(Buffer[8])+Ord(Buffer[9])*256;
FImageSpec.Y:=Ord(Buffer[10])+Ord(Buffer[11])*256;
FImageSpec.Width:=Ord(Buffer[12])+Ord(Buffer[13])*256;
FImageSpec.Height:=Ord(Buffer[14])+Ord(Buffer[15])*256;
FImageSpec.PixelDepth:=Ord(Buffer[16]);
FImageSpec.ImageDescriptor.AlphaChannelBits:=Ord(Buffer[17]) and 15;
FImageSpec.ImageDescriptor.Top:=(Ord(Buffer[17]) and 32)=32;
FImageSpec.ImageDescriptor.Left:=(Ord(Buffer[17]) and 16)=16;
FreeMem(Buffer);
if FID.Length>0 then
begin
GetMem( Buffer, FID.Length+1 );
Buffer[FID.Length] := #0;
Stream.Read(Buffer^,FID.Length);
FID.Text:=Buffer;
FreeMem(Buffer);
end
else FID.Text:='';
//Buffer := nil;
Free_And_Nil(FBitmap);
Free_And_Nil(FAlphaChannel);
if FColorMapType=1 then
begin
case FColorMapSpec.ColorMapEntrySize of
15: begin
Buffer:=AllocMem(FColorMapSpec.ColorMapLength*2);
Stream.Read(Buffer^,FColorMapSpec.ColorMapLength*2);
for i:=0 to FColorMapSpec.ColorMapLength-1 do
begin
Color16:=Ord(Buffer[(i*2)+0])+Ord(Buffer[(i*2)+1])*256;
FColorMap[i].Blue:=Color16to24[Color16 and 31];
FColorMap[i].Green:=Color16to24[(Color16 and 992) shr 5];
FColorMap[i].Red:=Color16to24[(Color16 and 31744) shr 10];
FColorMap[i].Alpha:=0;
end;
end;
16: begin
Buffer:=AllocMem(FColorMapSpec.ColorMapLength*2);
Stream.Read(Buffer^,FColorMapSpec.ColorMapLength*2);
for i:=0 to FColorMapSpec.ColorMapLength-1 do
begin
Color16:=Ord(Buffer[(i*2)+0])+Ord(Buffer[(i*2)+1])*256;
FColorMap[i].Blue:=Color16to24[Color16 and 31];
FColorMap[i].Green:=Color16to24[(Color16 and 992) shr 5];
FColorMap[i].Red:=Color16to24[(Color16 and 31744) shr 10];
FColorMap[i].Alpha:=0;
end;
end;
24: begin
Buffer:=AllocMem(FColorMapSpec.ColorMapLength*3);
Stream.Read(Buffer^,FColorMapSpec.ColorMapLength*3);
for i:=0 to FColorMapSpec.ColorMapLength-1 do
begin
FColorMap[i].Blue:=Ord(Buffer[(i*3)+0]);
FColorMap[i].Green:=Ord(Buffer[(i*3)+1]);
FColorMap[i].Red:=Ord(Buffer[(i*3)+2]);
FColorMap[i].Alpha:=0;
end;
end;
32: begin
Buffer:=AllocMem(FColorMapSpec.ColorMapLength*4);
Stream.Read(Buffer^,FColorMapSpec.ColorMapLength*4);
for i:=0 to FColorMapSpec.ColorMapLength-1 do
begin
FColorMap[i].Blue:=Ord(Buffer[(i*4)+0]);
FColorMap[i].Green:=Ord(Buffer[(i*4)+1]);
FColorMap[i].Red:=Ord(Buffer[(i*4)+2]);
FColorMap[i].Alpha:=Ord(Buffer[(i*4)+3]);
end;
end;
else Exit;
end;
FreeMem(Buffer);
end;
if (FImageSpec.Width = 0) or (FImageSpec.Height = 0) then Exit;
FBitmap := NewDibBitmap(FImageSpec.Width,FImageSpec.Height, pf32bit);
FAlphaChannel := NewDibBitmap(FImageSpec.Width,FImageSpec.Height,pf32bit);
LineSize:=FBitmap.Width*(FImageSpec.PixelDepth div 8);
Buffer:=AllocMem(LineSize);
if Buffer = nil then Exit;
TRY
case FImageType of
NO_IMAGEDATA_INCLUDED:
begin
FTargaType:=ttNoImageData;
end;
COLORMAPPED_IMAGE:
begin
FTargaType:=ttColorMapedImage;
case FImageSpec.PixelDepth of
8: begin
FColorDepth:=cd8bit;
FIncludeAlphaChannel:=False;
for i:=0 to FImageSpec.Height-1 do
begin
if not FImageSpec.ImageDescriptor.Top and not FImageSpec.ImageDescriptor.Left then
LineBuffer:=FBitmap.ScanLine[FImageSpec.Height-(i+1)]
else
LineBuffer:=FBitmap.ScanLine[i];
Stream.Read(Buffer^,LineSize);
for j:=0 to FImageSpec.Width-1 do
begin
LineBuffer[(j*4)]:=FColorMap[Ord(Buffer[j])].Blue;
LineBuffer[(j*4)+1]:=FColorMap[Ord(Buffer[j])].Green;
LineBuffer[(j*4)+2]:=FColorMap[Ord(Buffer[j])].Red;
end;
end;
end;
16: begin
end;
24: begin
end;
32: begin
end;
else Free_And_Nil( FBitmap );
Free_And_Nil( FAlphaChannel );
Exit;
end;
end;
TRUECOLOR_IMAGE:
begin
FTargaType:=ttTrueColorImage;
case FImageSpec.PixelDepth of
16: begin
FColorDepth:=cd16bit;
FIncludeAlphaChannel:=False;
for i:=0 to FImageSpec.Height-1 do
begin
if not FImageSpec.ImageDescriptor.Top and not FImageSpec.ImageDescriptor.Left then
LineBuffer:=FBitmap.ScanLine[FImageSpec.Height-(i+1)]
else
LineBuffer:=FBitmap.ScanLine[i];
Stream.Read(Buffer^,LineSize);
for j:=0 to FImageSpec.Width-1 do
begin
tmp16:=Ord(Buffer[j*2])+Ord(Buffer[j*2+1])*256;
LineBuffer[(j*4)]:=Color16to24[(tmp16 and 31)];
LineBuffer[(j*4)+1]:=Color16to24[((tmp16 and 992) shr 5)];
LineBuffer[(j*4)+2]:=Color16to24[((tmp16 and 31744) shr 10)];
end;
end;
end;
24: begin
FColorDepth:=cd24bit;
FIncludeAlphaChannel:=False;
for i:=0 to FImageSpec.Height-1 do
begin
if not FImageSpec.ImageDescriptor.Top and not FImageSpec.ImageDescriptor.Left then
LineBuffer:=FBitmap.ScanLine[FImageSpec.Height-(i+1)]
else
LineBuffer:=FBitmap.ScanLine[i];
Stream.Read(Buffer^,LineSize);
for j:=0 to FImageSpec.Width-1 do
begin
LineBuffer[(j*4)]:=Ord(Buffer[j*3]);
LineBuffer[(j*4)+1]:=Ord(Buffer[j*3+1]);
LineBuffer[(j*4)+2]:=Ord(Buffer[j*3+2]);
end;
end;
end;
32: begin
FColorDepth:=cd32bit;
FIncludeAlphaChannel:=True;
for i:=0 to FImageSpec.Height-1 do
begin
if not FImageSpec.ImageDescriptor.Top and not FImageSpec.ImageDescriptor.Left then
begin
LineBuffer:=FBitmap.ScanLine[FImageSpec.Height-(i+1)];
AlphaBuffer:=FAlphaChannel.ScanLine[FImageSpec.Height-(i+1)];
end
else
begin
LineBuffer:=FBitmap.ScanLine[i];
AlphaBuffer:=FAlphaChannel.ScanLine[i];
end;
Stream.Read(Buffer^,LineSize);
for j:=0 to FImageSpec.Width-1 do
begin
LineBuffer[(j*4)]:=Ord(Buffer[j*4]);
LineBuffer[(j*4)+1]:=Ord(Buffer[j*4+1]);
LineBuffer[(j*4)+2]:=Ord(Buffer[j*4+2]);
AlphaBuffer[(j*4)]:=Ord(Buffer[j*4+3]);
AlphaBuffer[(j*4)+1]:=Ord(Buffer[j*4+3]);
AlphaBuffer[(j*4)+2]:=Ord(Buffer[j*4+3]);
end;
end;
end;
end;
end;
BLACKANDWHITE_IMAGE: GetBAWImageType(False);
RLE_COLORMAPPED_IMAGE:
begin
FTargaType:=ttRLEColorMapedImage;
case FImageSpec.PixelDepth of
8: begin
FColorDepth:=cd8bit;
FIncludeAlphaChannel:=False;
RLEBuffer:=AllocMem(LineSize*2);
for i:=0 to FImageSpec.Height-1 do
begin
if not FImageSpec.ImageDescriptor.Top and not FImageSpec.ImageDescriptor.Left then
LineBuffer:=FBitmap.ScanLine[FImageSpec.Height-(i+1)]
else
LineBuffer:=FBitmap.ScanLine[i];
ReadLength:=Stream.Read(RLEBuffer^,LineSize*2);
Stream.Position:=Stream.Position-ReadLength+RLEDecompress(FImageSpec.Width,RLEBuffer, Buffer);
for j:=0 to FImageSpec.Width-1 do
begin
LineBuffer[(j*4)]:=FColorMap[Ord(Buffer[j])].Blue;
LineBuffer[(j*4)+1]:=FColorMap[Ord(Buffer[j])].Green;
LineBuffer[(j*4)+2]:=FColorMap[Ord(Buffer[j])].Red;
end;
end;
end;
16: begin
end;
24: begin
end;
32: begin
end;
end;
end;
RLE_TRUECOLOR_IMAGE:
begin
FTargaType:=ttRLETrueColorImage;
case FImageSpec.PixelDepth of
16: begin
FColorDepth:=cd16bit;
FIncludeAlphaChannel:=False;
RLEBuffer:=AllocMem(LineSize*2);
for i:=0 to FImageSpec.Height-1 do
begin
if not FImageSpec.ImageDescriptor.Top and not FImageSpec.ImageDescriptor.Left then
LineBuffer:=FBitmap.ScanLine[FImageSpec.Height-(i+1)]
else
LineBuffer:=FBitmap.ScanLine[i];
ReadLength:=Stream.Read(RLEBuffer^,LineSize*2);
Stream.Position:=Stream.Position-ReadLength+RLEDecompress(FImageSpec.Width*2,RLEBuffer, Buffer);
for j:=0 to FImageSpec.Width-1 do
begin
tmp16:=Ord(Buffer[j*2])+Ord(Buffer[j*2+1])*256;
LineBuffer[(j*4)]:=Color16to24[(tmp16 and 31)];
LineBuffer[(j*4)+1]:=Color16to24[((tmp16 and 992) shr 5)];
LineBuffer[(j*4)+2]:=Color16to24[((tmp16 and 31744) shr 10)];
end;
end;
FreeMem(RLEBuffer);
end;
24: begin
FColorDepth:=cd24bit;
FIncludeAlphaChannel:=False;
RLEBuffer:=AllocMem(LineSize*2);
for i:=0 to FImageSpec.Height-1 do
begin
if not FImageSpec.ImageDescriptor.Top and not FImageSpec.ImageDescriptor.Left then
LineBuffer:=FBitmap.ScanLine[FImageSpec.Height-(i+1)]
else
LineBuffer:=FBitmap.ScanLine[i];
ReadLength:=Stream.Read(RLEBuffer^,LineSize*2);
Stream.Position:=Stream.Position-ReadLength+RLEDecompress(FImageSpec.Width*3,RLEBuffer, Buffer);
for j:=0 to FImageSpec.Width-1 do
begin
LineBuffer[(j*4)]:=Ord(Buffer[j*3]);
LineBuffer[(j*4)+1]:=Ord(Buffer[j*3+1]);
LineBuffer[(j*4)+2]:=Ord(Buffer[j*3+2]);
end;
end;
FreeMem(RLEBuffer);
end;
32: begin
FColorDepth:=cd32bit;
FIncludeAlphaChannel:=True;
RLEBuffer:=AllocMem(LineSize*2);
for i:=0 to FImageSpec.Height-1 do
begin
if not FImageSpec.ImageDescriptor.Top and not FImageSpec.ImageDescriptor.Left then
begin
LineBuffer:=FBitmap.ScanLine[FImageSpec.Height-(i+1)];
AlphaBuffer:=FAlphaChannel.ScanLine[FImageSpec.Height-(i+1)];
end
else
begin
LineBuffer:=FBitmap.ScanLine[i];
AlphaBuffer:=FAlphaChannel.ScanLine[i];
end;
ReadLength:=Stream.Read(RLEBuffer^,LineSize*2);
Stream.Position:=Stream.Position-ReadLength+RLEDecompress(FImageSpec.Width*4,RLEBuffer, Buffer);
for j:=0 to FImageSpec.Width-1 do
begin
LineBuffer[(j*4)]:=Ord(Buffer[j*4]);
LineBuffer[(j*4)+1]:=Ord(Buffer[j*4+1]);
LineBuffer[(j*4)+2]:=Ord(Buffer[j*4+2]);
AlphaBuffer[(j*4)]:=Ord(Buffer[j*4+3]);
AlphaBuffer[(j*4)+1]:=Ord(Buffer[j*4+3]);
AlphaBuffer[(j*4)+2]:=Ord(Buffer[j*4+3]);
end;
end;
FreeMem(RLEBuffer);
end;
end;
end;
RLE_BLACKANDWHITE_IMAGE: GetBAWImageType(True);
end;
FINALLY
FreeMem(Buffer);
END;
end;
procedure TTarga.SaveToStream(Stream: PStream);
type
TRGBCount = record
RGBA: TRGBA;
Count: Integer;
end;
// TRGBCountPalete = array[0..MaxInt] of TRGBCount;
var Buffer: PChar;
RLEBuffer: PChar;
i, j: Integer;
Color16: Word;
LineSize, RLELineSize: Integer;
LineBuffer, AlphaBuffer: PByteArray;
{ ReadLength: Integer;
PaletePos: Integer;
tmpPalete: TRGBA;
CountPalete: TRGBCountPalete;
IsInPalete: Boolean;}
tmpPosition: Integer;
BytePerPixel: Byte;
begin
case FTargaType of
ttRLETrueColorImage:
begin
Buffer:=AllocMem(18);
Buffer[0]:=Chr(0);
Buffer[1]:=Chr(0);
Buffer[2]:=Chr(RLE_TRUECOLOR_IMAGE);
Buffer[3]:=Chr(0);
Buffer[4]:=Chr(0);
Buffer[5]:=Chr(0);
Buffer[6]:=Chr(0);
Buffer[7]:=Chr(0);
Buffer[8]:=Chr(0);
Buffer[9]:=Chr(0);
Buffer[10]:=Chr(0);
Buffer[11]:=Chr(0);
Buffer[12]:=Chr(FBitmap.Width mod 256);
Buffer[13]:=Chr(FBitmap.Width div 256);
Buffer[14]:=Chr(FBitmap.Height mod 256);
Buffer[15]:=Chr(FBitmap.Height div 256);
Buffer[16]:=Chr(24);
Buffer[17]:=Chr(0);
Stream.Write(Buffer^,18);
FreeMem(Buffer);
LineSize:=FBitmap.Width*3;
Buffer:=AllocMem(LineSize);
RLEBuffer:=AllocMem(LineSize*2);
for i:=0 to FBitmap.Height-1 do
begin
LineBuffer:=FBitmap.ScanLine[FBitmap.Height-(i+1)];
for j:=0 to FBitmap.Width-1 do
begin
Buffer[j*3]:=Chr(LineBuffer[j*4]);
Buffer[j*3+1]:=Chr(LineBuffer[j*4+1]);
Buffer[j*3+2]:=Chr(LineBuffer[j*4+2]);
end;
RLELineSize:=RLECompress(LineSize,RLEBuffer,Buffer);
tmpPosition:=Stream.Position;
Stream.Size:=Stream.Size+RLELineSize;
Stream.Position:=tmpPosition;
Stream.Write(RLEBuffer^,RLELineSize);
end;
FreeMem(Buffer);
FreeMem(RLEBuffer);
end;
else
begin
if (FBitmap.Width<>FAlphaChannel.Width) or (FBitmap.Height<>FAlphaChannel.Height) then
begin
FAlphaChannel.Width:=FBitmap.Width;
FAlphaChannel.Height:=FBitmap.Height;
end;
case FColorDepth of
cd16bit: BytePerPixel:=2;
cd24bit: BytePerPixel:=3;
cd32bit: BytePerPixel:=4;
else BytePerPixel:=3;
end;
Buffer:=AllocMem(18);
Buffer[0]:=Chr(0);
Buffer[1]:=Chr(0);
Buffer[2]:=Chr(TRUECOLOR_IMAGE);
Buffer[3]:=Chr(0);
Buffer[4]:=Chr(0);
Buffer[5]:=Chr(0);
Buffer[6]:=Chr(0);
Buffer[7]:=Chr(0);
Buffer[8]:=Chr(0);
Buffer[9]:=Chr(0);
Buffer[10]:=Chr(0);
Buffer[11]:=Chr(0);
Buffer[12]:=Chr(FBitmap.Width mod 256);
Buffer[13]:=Chr(FBitmap.Width div 256);
Buffer[14]:=Chr(FBitmap.Height mod 256);
Buffer[15]:=Chr(FBitmap.Height div 256);
Buffer[16]:=Chr(8*BytePerPixel);
Buffer[17]:=Chr(0);
Stream.Write(Buffer^,18);
FreeMem(Buffer);
LineSize:=FBitmap.Width*BytePerPixel;
Buffer:=AllocMem(LineSize);
for i:=0 to FBitmap.Height-1 do
begin
LineBuffer:=FBitmap.ScanLine[FBitmap.Height-(i+1)];
AlphaBuffer:=FAlphaChannel.ScanLine[FBitmap.Height-(i+1)];
for j:=0 to FBitmap.Width-1 do
begin
case FColorDepth of
cd16bit: begin
Color16:=(Word(LineBuffer[j*4]) div 8) or ((Word(LineBuffer[(j*4)+1]) div 8) shl 5) or ((Word(LineBuffer[(j*4)+2]) div 8) shl 10);
Buffer[(j*2)]:=Chr(Lo(Color16));
Buffer[(j*2)+1]:=Chr(Hi(Color16));
end;
cd24bit: begin
Buffer[j*3]:=Chr(LineBuffer[j*4]);
Buffer[j*3+1]:=Chr(LineBuffer[j*4+1]);
Buffer[j*3+2]:=Chr(LineBuffer[j*4+2]);
end;
cd32bit: begin
Buffer[j*4]:=Chr(LineBuffer[j*4]);
Buffer[j*4+1]:=Chr(LineBuffer[j*4+1]);
Buffer[j*4+2]:=Chr(LineBuffer[j*4+2]);
Buffer[j*4+3]:=Chr(AlphaBuffer[j*4]);
end;
end;
end;
Stream.Write(Buffer^,LineSize);
end;
FreeMem(Buffer);
end;
{ ttColorMapedImage:
begin
PaletePos:=0;
for i:=0 to Bitmap.Height-1 do
begin
LineBuffer:=Bitmap.ScanLine[Bitmap.Height+i];
for j:=0 to Bitmap.Width-1 do
begin
tmpPalete.Red:=Ord(LineBuffer[j*4]);
tmpPalete.Green:=Ord(LineBuffer[j*4+1]);
tmpPalete.Blue:=Ord(LineBuffer[j*4+2]);
tmpPalete.Alpha:=0;
IsInPalete:=False;
for k:=0 to PaletePos-1 do if tmpPalete=CountPalete[k].RGBA then
begin
IsInPalete:=True;
Inc(CountPalete[k].Count);
end;
if
end;
end;
Buffer:=AllocMem(18);
Buffer[0]:=Chr(0);
Buffer[1]:=Chr(0);
Buffer[2]:=Chr(COLORMAPPED_IMAGE);
Buffer[3]:=Chr(0);
Buffer[4]:=Chr(0);
Buffer[5]:=Chr(0);
Buffer[6]:=Chr(0);
Buffer[7]:=Chr(0);
Buffer[8]:=Chr(0);
Buffer[9]:=Chr(0);
Buffer[10]:=Chr(0);
Buffer[11]:=Chr(0);
Buffer[12]:=Chr(Bitmap.Width mod 256);
Buffer[13]:=Chr(Bitmap.Width div 256);
Buffer[14]:=Chr(Bitmap.Height mod 256);
Buffer[15]:=Chr(Bitmap.Height div 256);
Buffer[16]:=Chr(8);
Buffer[17]:=Chr(0);
fsOpen.Size:=18+Bitmap.Width*Bitmap.Height*3;
fsOpen.Position:=0;
fsOpen.Write(Buffer^,18);
FreeMem(Buffer);
LineSize:=Bitmap.Width*3;
Buffer:=AllocMem(LineSize);
RLEBuffer:=AllocMem(LineSize*2);
for i:=0 to Bitmap.Height-1 do
begin
LineBuffer:=Bitmap.ScanLine[Bitmap.Height-(i+1)];
for j:=0 to Bitmap.Width-1 do
begin
Buffer[j*3]:=Chr(LineBuffer[j*4]);
Buffer[j*3+1]:=Chr(LineBuffer[j*4+1]);
Buffer[j*3+2]:=Chr(LineBuffer[j*4+2]);
end;
fsOpen.Write(Buffer^,LineSize);
end;
FreeMem(Buffer);
end;}
end;
end;
function TTarga.RLEDecompress(DataLength: Integer; var RLEBuffer: PChar; var Buffer: PChar): Integer;
var RLEPacketType: Boolean;
RLEPacketLength: Integer;
RAWDataPosition: Integer;
RLEPacketPosition: Integer;
j: Integer;
begin
RLEPacketPosition:=0;
RAWDataPosition:=0;
case FImageSpec.PixelDepth of
8: begin
while True do
begin
RLEPacketType:=Ord(RLEBuffer[RLEPacketPosition])>127;
RLEPacketLength:=1+Ord(RLEBuffer[RLEPacketPosition]) and 127;
if RLEPacketType then
begin
for j:=0 to RLEPacketLength-1 do
begin
Buffer[RAWDataPosition]:=RLEBuffer[RLEPacketPosition+1];
Inc(RAWDataPosition);
end;
Inc(RLEPacketPosition,2)
end
else
begin
for j:=0 to RLEPacketLength-1 do
begin
Buffer[RAWDataPosition]:=RLEBuffer[RLEPacketPosition+j+1];
Inc(RAWDataPosition);
end;
Inc(RLEPacketPosition,RLEPacketLength+1)
end;
if RAWDataPosition>=DataLength then Break;
end;
end;
16: begin
while True do
begin
RLEPacketType:=Ord(RLEBuffer[RLEPacketPosition])>127;
RLEPacketLength:=1+Ord(RLEBuffer[RLEPacketPosition]) and 127;
if RLEPacketType then
begin
for j:=0 to RLEPacketLength-1 do
begin
Buffer[RAWDataPosition]:=RLEBuffer[RLEPacketPosition+1];
Buffer[RAWDataPosition+1]:=RLEBuffer[RLEPacketPosition+2];
Inc(RAWDataPosition,2);
end;
Inc(RLEPacketPosition,3)
end
else
begin
for j:=0 to RLEPacketLength-1 do
begin
Buffer[RAWDataPosition]:=RLEBuffer[RLEPacketPosition+j*2+1];
Buffer[RAWDataPosition+1]:=RLEBuffer[RLEPacketPosition+j*2+2];
Inc(RAWDataPosition,2);
end;
Inc(RLEPacketPosition,RLEPacketLength*2+1)
end;
if RAWDataPosition>=DataLength then Break;
end;
end;
24: begin
while True do
begin
RLEPacketType:=Ord(RLEBuffer[RLEPacketPosition])>127;
RLEPacketLength:=(Ord(RLEBuffer[RLEPacketPosition]) and 127)+1;
if RLEPacketType then
begin
for j:=0 to RLEPacketLength-1 do
begin
Buffer[RAWDataPosition]:=RLEBuffer[RLEPacketPosition+1];
Buffer[RAWDataPosition+1]:=RLEBuffer[RLEPacketPosition+2];
Buffer[RAWDataPosition+2]:=RLEBuffer[RLEPacketPosition+3];
Inc(RAWDataPosition,3);
end;
Inc(RLEPacketPosition,4)
end
else
begin
for j:=0 to RLEPacketLength-1 do
begin
Buffer[RAWDataPosition]:=RLEBuffer[RLEPacketPosition+j*3+1];
Buffer[RAWDataPosition+1]:=RLEBuffer[RLEPacketPosition+j*3+2];
Buffer[RAWDataPosition+2]:=RLEBuffer[RLEPacketPosition+j*3+3];
Inc(RAWDataPosition,3);
end;
Inc(RLEPacketPosition,RLEPacketLength*3+1)
end;
if RAWDataPosition>=DataLength then Break;
end;
end;
32: begin
while True do
begin
RLEPacketType:=Ord(RLEBuffer[RLEPacketPosition])>127;
RLEPacketLength:=1+Ord(RLEBuffer[RLEPacketPosition]) and 127;
if RLEPacketType then
begin
for j:=0 to RLEPacketLength-1 do
begin
Buffer[RAWDataPosition]:=RLEBuffer[RLEPacketPosition+1];
Buffer[RAWDataPosition+1]:=RLEBuffer[RLEPacketPosition+2];
Buffer[RAWDataPosition+2]:=RLEBuffer[RLEPacketPosition+3];
Buffer[RAWDataPosition+3]:=RLEBuffer[RLEPacketPosition+4];
Inc(RAWDataPosition,4);
end;
Inc(RLEPacketPosition,5)
end
else
begin
for j:=0 to RLEPacketLength-1 do
begin
Buffer[RAWDataPosition]:=RLEBuffer[RLEPacketPosition+j*4+1];
Buffer[RAWDataPosition+1]:=RLEBuffer[RLEPacketPosition+j*4+2];
Buffer[RAWDataPosition+2]:=RLEBuffer[RLEPacketPosition+j*4+3];
Buffer[RAWDataPosition+3]:=RLEBuffer[RLEPacketPosition+j*4+4];
Inc(RAWDataPosition,4);
end;
Inc(RLEPacketPosition,RLEPacketLength*4+1)
end;
if RAWDataPosition>=DataLength then Break;
end;
end;
end;
Result:=RLEPacketPosition;
end;
function TTarga.RLECompress(DataLength: Integer; var RLEBuffer: PChar; var Buffer: PChar): Integer;
var ByteR, ByteG, ByteB: Byte;
ByteCount: Integer;
RAWDataPosition: Integer;
IsRLEPacket: Boolean;
RLEDataPosition: Integer;
RAWPacketHeaderPos: Integer;
begin
IsRLEPacket:=False;
RAWDataPosition:=0;
RLEDataPosition:=0;
RAWPacketHeaderPos:=0;
ByteCount:=0;
ByteR:=Ord(Buffer[RAWDataPosition]);
ByteG:=Ord(Buffer[RAWDataPosition+1]);
ByteB:=Ord(Buffer[RAWDataPosition+2]);
Inc(RAWDataPosition,3);
while True do
begin
if (RAWDataPosition>=DataLength) or (ByteCount=127) then
begin
if IsRLEPacket then
begin
RLEBuffer[RLEDataPosition]:=Chr(128+ByteCount);
RLEBuffer[RLEDataPosition+1]:=Chr(ByteR);
RLEBuffer[RLEDataPosition+2]:=Chr(ByteG);
RLEBuffer[RLEDataPosition+3]:=Chr(ByteB);
Inc(RLEDataPosition,4);
Inc(RAWDataPosition,3);
ByteCount:=0;
RAWPacketHeaderPos:=RLEDataPosition;
IsRLEPacket:=False;
end
else
begin
RLEBuffer[RAWPacketHeaderPos]:=Chr(ByteCount);
if ByteCount>0 then
begin
RLEBuffer[RLEDataPosition]:=Chr(ByteR);
RLEBuffer[RLEDataPosition+1]:=Chr(ByteG);
RLEBuffer[RLEDataPosition+2]:=Chr(ByteB);
Inc(RLEDataPosition,3)
end
else
begin
RLEBuffer[RLEDataPosition+1]:=Chr(ByteR);
RLEBuffer[RLEDataPosition+2]:=Chr(ByteG);
RLEBuffer[RLEDataPosition+3]:=Chr(ByteB);
Inc(RLEDataPosition,4);
end;
Inc(RAWDataPosition,3);
ByteR:=Ord(Buffer[RAWDataPosition]);
ByteG:=Ord(Buffer[RAWDataPosition+1]);
ByteB:=Ord(Buffer[RAWDataPosition+2]);
ByteCount:=0;
RAWPacketHeaderPos:=RLEDataPosition;
end;
if (RAWDataPosition>=DataLength) then Break;
end;
if (ByteR=Ord(Buffer[RAWDataPosition])) and (ByteG=Ord(Buffer[RAWDataPosition+1])) and (ByteB=Ord(Buffer[RAWDataPosition+2])) then
begin
if not IsRLEPacket then ByteCount:=0;
Inc(ByteCount);
Inc(RAWDataPosition,3);
IsRLEPacket:=True;
end
else
begin
if IsRLEPacket then
begin
RLEBuffer[RLEDataPosition]:=Chr(128+ByteCount);
RLEBuffer[RLEDataPosition+1]:=Chr(ByteR);
RLEBuffer[RLEDataPosition+2]:=Chr(ByteG);
RLEBuffer[RLEDataPosition+3]:=Chr(ByteB);
Inc(RLEDataPosition,4);
ByteR:=Ord(Buffer[RAWDataPosition]);
ByteG:=Ord(Buffer[RAWDataPosition+1]);
ByteB:=Ord(Buffer[RAWDataPosition+2]);
Inc(RAWDataPosition,3);
ByteCount:=0;
RAWPacketHeaderPos:=RLEDataPosition;
IsRLEPacket:=False;
end
else
begin
RLEBuffer[RAWPacketHeaderPos]:=Chr(ByteCount);
if ByteCount>0 then
begin
RLEBuffer[RLEDataPosition]:=Chr(ByteR);
RLEBuffer[RLEDataPosition+1]:=Chr(ByteG);
RLEBuffer[RLEDataPosition+2]:=Chr(ByteB);
Inc(RLEDataPosition,3)
end
else
begin
RLEBuffer[RLEDataPosition+1]:=Chr(ByteR);
RLEBuffer[RLEDataPosition+2]:=Chr(ByteG);
RLEBuffer[RLEDataPosition+3]:=Chr(ByteB);
Inc(RLEDataPosition,4);
end;
ByteR:=Ord(Buffer[RAWDataPosition]);
ByteG:=Ord(Buffer[RAWDataPosition+1]);
ByteB:=Ord(Buffer[RAWDataPosition+2]);
Inc(RAWDataPosition,3);
Inc(ByteCount);
end;
end;
end;
Result:=RLEDataPosition;
end;
end.
Reference in New Issue Copy Permalink