K210.ORG

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.