Главная » Delphi » Графика » Читаем и отображаем TGA с альфа-каналом.

Читаем и отображаем TGA с альфа-каналом.

16:30
unit Unit1;
 
interface
 
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
 
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
BH: HBITMAP;
alphachannel: boolean;
b_width, b_height: integer;
public
{ Public declarations }
end;
 
type TGA_Header = packed record // http://allrussweb.com.ru/delphi/filesystem/formatfile/005.php
IDLength: byte; // Длина ID-поля (ID Field Length)
ColorMapType: byte; // TТип цветовой карты (Color-map Type)
ImageType: byte; // Тип изображения (Image Type)
FirstEntryIndex: WORD; //Первое включение цветовой карты (First Color-map Entry)
Length: WORD; //Длина цветовой карты (Color-map Length)
EntrySize: byte; //Размер цветовой карты (Color-map Entry Size)
xOrigin, //Горизонтальная координата начала изображения (Image X Origin)
yOrigin, //Вертикальная координата начала изображения (Image Y Origin)
Width, //Ширина изображения (Image Width)
Height: WORD; //Высота изображения (Image Height)
PixelDepth, //Бит на пиксел (Bits-Per-Pixel)
ImageDescriptor: byte; // Биты дескриптора изображения (Image-Descriptor Bits)
end;
 
type
TCByte = array[0..3] of byte;
PColorBytes = ^TColorBytes;
TColorBytes = array[0..0] of TCByte;
var
Form1: TForm1;
implementation
 
{$R *.dfm}
 
function Load32bitTGA2(pFileName: PChar; var alpha: boolean; var b_width, b_height: integer): HBITMAP;
var
handle: HWND;
header: TGA_Header;
dwRead: DWORD;
bmp: BITMAPINFO;
pBits: PColorBytes;
hBmp: HBITMAP;
y: integer;
begin
result := 0;
 
handle := CreateFile(pFileName, GENERIC_READ, FILE_SHARE_READ,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
 
if handle = INVALID_HANDLE_VALUE then begin
result := 0;
exit;
end;
 
dwRead := 0;
ReadFile(handle, header, sizeof(header), dwRead, nil);
 
if ((header.IDLength <> 0) or (header.ColorMapType <> 0) or (header.ImageType <> 2) {<--RLE}
{ or(header.PixelDepth = 32)or (header.ImageDescriptor <> 8)}) then
begin
CloseHandle(handle);
result := 0;
exit;
end;
 
fillchar(bmp, sizeof(BITMAPINFO), 0);
bmp.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
 
if header.ImageDescriptor and $10 = $10 then
bmp.bmiHeader.biWidth := -header.Width
else
bmp.bmiHeader.biWidth := header.Width;
 
b_width := header.Width;
 
if header.ImageDescriptor and $20 = $20 then
bmp.bmiHeader.biHeight := -header.Height
else
bmp.bmiHeader.biHeight := header.Height;
 
b_height := header.Height;
bmp.bmiHeader.biPlanes := 1;
bmp.bmiHeader.biBitCount := header.PixelDepth;
bmp.bmiHeader.biCompression := 0;
hBmp := CreateDIBSection(0, bmp, DIB_RGB_COLORS, Pointer(pBits), 0, 0);
 
if (hBmp = 0) then begin
CloseHandle(handle);
result := 0;
exit;
end;
alpha := false;
 
case header.PixelDepth of
32: begin
ReadFile(handle, pBits^, header.Width * header.Height * 4, dwRead, nil);
alpha := true;
end;
24: ReadFile(handle, pBits^, header.Width * header.Height * 3, dwRead, nil);
16: ReadFile(handle, pBits^, header.Width * header.Height * 2, dwRead, nil);
end;
 
CloseHandle(handle);
 
if alpha then
for y := 0 to header.Width * header.Height - 2 do
begin
pBits^[y][0] := pBits^[y][0] * pBits^[y][3] div 255;
pBits^[y][1] := pBits^[y][1] * pBits^[y][3] div 255;
pBits^[y][2] := pBits^[y][2] * pBits^[y][3] div 255;
end;
 
result := hBmp;
end;
 
procedure AlphaDraw(HDC: hDC; x, y, width, height: integer; hBmp: HBITMAP; alpha: boolean);
var
hMemDC: LongWord;
hOld: HGDIOBJ;
pixelblend: _BLENDFUNCTION;
begin
hMemDC := CreateCompatibleDC(hDC);
hOld := SelectObject(hMemDC, hBmp);
pixelblend.BlendOp := AC_SRC_OVER;
pixelblend.BlendFlags := 0;
pixelblend.SourceConstantAlpha := 255;
 
if alpha then
pixelblend.AlphaFormat := AC_SRC_ALPHA
else
pixelblend.AlphaFormat := 0;
 
AlphaBlend(hDC, x, y,
width, height,
hMemDC, 0, 0, width, height, pixelblend);
 
SelectObject(hMemDC, hOld);
DeleteObject(hMemDC);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenDialog1.Filter := 'TGA files (*.tga)|*.TGA';
end;
 
procedure TForm1.FormPaint(Sender: TObject);
begin
if BH <> 0 then begin
AlphaDraw(Canvas.Handle, 0, 0,
b_width,
b_height,
BH, alphachannel);
end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
BH := Load32bitTGA2(pchar(OpenDialog1.FileName), alphachannel, b_width, b_height);
Invalidate;
end;
end;
 
end.