Работа с TGA файлами

const
 FERRORMSG2 = 'Sorry, Unsupported Compressed(RLE) File Format';
 FERRORMSG3 = 'Sorry, Unsupported More Than 256 Colours File Format';
type
 TArrBuff = array[1..512] of Byte;
 TPalette_Cell = record
  b2, g2, r2: byte;
 end;
 TPal = array[0..255] of TPalette_Cell;
 TPPal = ^TPal;
 TTGA_Header = record // Targa(TGA) HEADER //
  IDLength, ColorMap, ImageType: byte;
  ClrMapSpes: array[1..5] of byte;
  XAwal, YAwal, Width, Height: SmallInt;
  BpPixel, ImageDescription: byte;
 end;
var
 pal: TPPal;
 pFile: file;
 buffer: TArrBuff;
 FTgaHeader: TTGA_Header;
procedure THPTGA.ReadImageData2Bitmap;
var
 i, j, idx: integer;
begin
 Seek(pFile, sizeof(FtgaHeader) + FtgaHeader.IDLength + 768);
 for i := FtgaHeader.Height - 1 downto FtgaHeader.YAwal do
 begin
  BlockRead(pFile, buffer, FtgaHeader.Width);
  for j := FtgaHeader.XAwal to FtgaHeader.Width - 1 do
  begin
  idx := j - FtgaHeader.XAwal + 1;
  SetPixel(Bitmap.Canvas.Handle, j, i, rgb(pal^[buffer[idx]].r2,
  pal^[buffer[idx]].g2, pal^[buffer[idx]].b2));
  end;
 end;
end;
procedure THPTGA.LoadFromFile(const FileName: string);
begin
 AssignFile(pFile, FileName);
{$I-}Reset(pFile, 1);
{$I+}
 if (IOResult = 0) then
 begin
  try
  BlockRead(pFile, FtgaHeader, SizeOf(FtgaHeader));
  // checking unsupported features here
  if (FtgaHeader.ImageType > 3) then
  begin
  MessageBox(Application.Handle, FERRORMSG2, 'TGA Viewer Error', MB_ICONHAND);
  exit;
  end;
  if (FtgaHeader.BpPixel > 8) then
  begin
  MessageBox(Application.Handle, FERRORMSG3, 'TGA Viewer Error', MB_ICONHAND);
  exit;
  end;
  GetMem(pal, 768);
  try
  Bitmap.Width := FtgaHeader.Width;
  Bitmap.Height := FtgaHeader.Height;
  // if use Color-Map and Uncompressed then read it
  if (FtgaHeader.ImageType = 1) then
  BlockRead(pFile, pal^, 768);
  ReadImageData2Bitmap;
  finally
  FreeMem(pal);
  end;
  finally
  CloseFile(pFile);
  end;
 end
 else
  MessageBox(Application.Handle, 'Error Opening File', 'TGA Viewer Error',
  MB_ICONHAND);
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
Проверка
Антиспам проверка
Image CAPTCHA
...