unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, GR32_Image, LibTiffDelphi, BGRABitmap;
type
{ TForm1 }
TForm1 = class(TForm)
Image_test: TImage32;
procedure FormShow(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
procedure TIFFReadRGBAImageSwapRB(Width,Height: Cardinal; Memory: Pointer);
{$IFDEF DELPHI_5}
type
PCardinal = ^Cardinal;
{$ENDIF}
var
m: PCardinal;
n: Cardinal;
o: Cardinal;
begin
m:=Memory;
for n:=0 to (Int64(Width))*(Int64(Height))-1 do
begin
o:=m^;
m^:= (o and $FF00FF00) or {G and A}
((o and $00FF0000) shr 16) or {B}
((o and $000000FF) shl 16); {R}
Inc(m);
end;
end;
function fn_PutTiffInImage32(p_string_file: String; p_TImage32_aux: TImage32):boolean;
var
OpenTiff: PTIFF;
FirstPageWidth,FirstPageHeight,Compression,Photometric: Cardinal;
l_TBGRABitmap_aux: TBGRABitmap;
l_TBitmap_Aux : TBitmap;
l_boolean_ok : boolean;
begin
l_boolean_ok := true;
OpenTiff:=TIFFOpen(p_string_file,'r');
if OpenTiff=nil then l_boolean_ok := false;
TIFFGetField(OpenTiff,TIFFTAG_IMAGEWIDTH,@FirstPageWidth);
TIFFGetField(OpenTiff,TIFFTAG_IMAGELENGTH,@FirstPageHeight);
TIFFGetField(OpenTiff,TIFFTAG_COMPRESSION,@Compression);
TIFFGetField(OpenTiff,TIFFTAG_PHOTOMETRIC,@Photometric);
if (Photometric = PHOTOMETRIC_YCBCR) then
begin
l_boolean_ok := false; //Not handled this subtype
end
else
begin
l_TBGRABitmap_aux := nil;
try
l_TBGRABitmap_aux:=TBGRABitmap.Create(FirstPageWidth,FirstPageHeight);
except
l_boolean_ok := false;
if l_TBGRABitmap_aux <> nil then l_TBGRABitmap_aux.Destroy;
TIFFClose(OpenTiff);
end;
try
try
TIFFReadRGBAImage(OpenTiff,FirstPageWidth,FirstPageHeight, PInteger(l_TBGRABitmap_aux.ScanLine[FirstPageHeight-1]),0);
TIFFReadRGBAImageSwapRB(FirstPageWidth,FirstPageHeight, PInteger(l_TBGRABitmap_aux.ScanLine[FirstPageHeight-1]));
except
l_boolean_ok := false;
end;
finally
TIFFClose(OpenTiff);
end;
if l_boolean_ok then
begin
l_TBitmap_Aux := TBitmap.Create;
l_TBitmap_Aux.Width:=FirstPageWidth;
l_TBitmap_Aux.Height:=FirstPageHeight;
l_TBitmap_Aux.PixelFormat:=pf32bit;
l_TBGRABitmap_aux.Draw(l_TBitmap_Aux.Canvas,0,0,true);
p_TImage32_aux.Bitmap.Assign(l_TBitmap_Aux);
l_TBitmap_Aux.Free;
l_TBGRABitmap_aux.Free;
end;
end;
Result := l_boolean_ok;
end;
{ TForm1 }
procedure TForm1.FormShow(Sender: TObject);
begin
if not fn_PutTiffInImage32('lazarus.tif',Image_test) then
begin
//put your message error here
end;
end;
end.