Das Tagged Image File Format (TIFF oder auch kurz TIF) ist ein Dateiformat zur Speicherung von Bilddaten. Es wurde ursprünglich von Aldus (1994 von Adobe übernommen) und Microsoft für die Farbseparation bei gescannten Rastergrafiken entwickelt. TIFF-Dateien besitzen den MIME-Typ image/tiff.
unit ReadTiffTags;
interface
{Unit ReadTiffTags.pas}
uses WinProcs, SysUtils,Controls,Classes,Graphics, Dialogs;
const
// Byte Order
tiffLittleEndian=$4949; // II: least significant byte to the most significant byte
// e.g. Intel
tiffBigEndian=$4D4D; // MM: most significant byte to least significant byte
// e.g. Motorola
// identifies TIFF file
tiffConfirm=$002A;
// Tiff Tags
tiffTag_ImageWidth = $0100;
tiffTag_ImageLength = $0101;
tiffTag_BitsPerSample = $0102;
tiffTag_Compression = $0103;
tiffTag_PhotometricInterpretation = $0106;
tiffTag_StripOffsets = $0111;
tiffTag_SamplesPerPixels = $0115;
tiffTag_RowsPerStrip = $0116;
tiffTag_StripByteCounts = $0117;
tiffTag_ColorMapOffset = $0140;
type
// Header structure
THeaderTiff=record
Endian : Word;
Confirm : Word;
FirstIFD: LongInt;
end;
// Image file Directory element (IFD)
TTagTiff=record
Tag : Word;
VarType : Word;
Count : LongInt;
Value : LongInt;
end;
PTagTiff=^TTagTiff;
TListTag=array[0..0] of TTagTiff;
PListTag=^TListTag;
// StripOffsets and StripByteCounts Information List
TStripInfo=record
StripOffsets : LongInt;
StripByteCounts : LongInt;
end;
PStripInfo=^TStripInfo;
TListStripInfo=array[0..0] of TStripInfo;
PListStripInfo=^TListStripInfo;
// ------------------------------------------------------------------
// Class containing the graphic information
// ------------------------------------------------------------------
TFileTiff=class;
TGraphicTiff=class
private
FCountTag : Word;
FError : Boolean;
FFileTiff : TFileTiff;
FFilePosition : LongInt;
FListTag : PListTag;
FNextIFD : LongInt;
FListStripInfo: PListStripInfo;
FCountStripInfo: Word;
protected
procedure LoadIFD(AFileHandle:Integer);
public
constructor Create(AFileTiff:TFileTiff); virtual;
procedure QueryGraphic(AStringList:TStringList);
destructor Destroy; override;
property Error :Boolean read FError;
property NextIFD :LongInt read FNextIFD;
function QueryGraphicByTag( TagId : Word ) : PTagTiff;
function QueryGraphicByOffsets( OffsetId : Word ) : PStripInfo;
function GetNoOfOffsets : Word;
end;
// ------------------------------------------------------------------
// Class containing image independent information
// ------------------------------------------------------------------
TFileTiff=class(TPersistent)
private
FFileName : TFileName;
FFileSize : LongInt;
FGraphicsList : TList;
FLittleEndian : Boolean;
FValid : Boolean;
protected
function AddGraphicFromFile(AFileHandle:Integer;AFileOffset:LongInt):TGraphicTiff;
procedure DeleteAll;
function GetGraphicCount:Integer; virtual;
procedure SetFileName(AFileName:TFileName); virtual;
public
constructor Create; virtual;
function GetGraphicTiff(AGraphicID:Byte):TGraphicTiff; virtual;
procedure DeleteGraphic(AGraphicID:Byte);
procedure ExchangeGraphic(AIndex1,AIndex2:Byte);
destructor Destroy; override;
property FileSize:LongInt read FFileSize;
property GraphicTiff[AGraphicID:Byte]:TGraphicTiff read GetGraphicTiff;
property GraphicCount:Integer read GetGraphicCount;
property LittleEndian:Boolean read FLittleEndian;
property Valid:Boolean read FValid;
published
property FileName:TFileName read FFileName write SetFileName;
end;
function SwapLongInt(ALongInt:LongInt):LongInt;
implementation
function SwapLongInt(ALongInt:LongInt):LongInt;
var
WordA :Word;
WordB :Word;
begin
WordA := Swap(HiWord(ALongInt));
WordB := Swap(LoWord(ALongInt));
SwapLongInt := MakeLong(WordA,WordB);
end;
{$R-}
// ------------------------------------------------------------------
// Class containing the graphic information
// ------------------------------------------------------------------
(*---------------------------------------------------------------*)
procedure TGraphicTiff.LoadIFD(AFileHandle:Integer);
var
TagLoop : Word;
NoOfStripByteCounts : LongInt;
NoOfStripOffsets : LongInt;
I : Integer;
begin
if Assigned(FFileTiff) and (AFileHandle>-1) then
begin
try
FFilePosition := FileSeek(AFileHandle,0,1); // actual position
FileRead(AFileHandle, FCountTag, 2); // read no of tags in Image file Directory
if not FFileTiff.LittleEndian then FCountTag := Swap(FCountTag);
if FCountTag>0 then
begin
// get memory for all IFD entries
GetMem(FListTag,SizeOf(TTagTiff)*FCountTag);
// read all ifd entries
FileRead(AFileHandle, FListTag^, SizeOf(TTagTiff)*FCountTag );
FFilePosition := FileSeek(AFileHandle,0,1); // actual position
if not FFileTiff.LittleEndian then // Swap Bytes
begin
for TagLoop := 0 to FCountTag-1 do
begin
with FListTag^[TagLoop] do
begin
Tag := Swap(Tag);
VarType := Swap(VarType);
Count := SwapLongInt(Count);
Value := SwapLongInt(Value);
end;
end;
end;
// Check No of StripByteCounts and No of StripOffsets
NoOfStripByteCounts := 0;
NoOfStripOffsets := 0;
FCountStripInfo := 0;
for TagLoop := 0 to FCountTag-1 do
begin
// Strip Byte Counts
if FListTag^[TagLoop].Tag = tiffTag_StripByteCounts then
begin
NoOfStripByteCounts := FListTag^[TagLoop].Count;
end;
// StripOffsets
if FListTag^[TagLoop].Tag = tiffTag_StripOffsets then
begin
NoOfStripOffsets := FListTag^[TagLoop].Count;
end;
end;
if (NoOfStripByteCounts = NoOfStripOffsets) then
begin
FCountStripInfo := NoOfStripByteCounts;
GetMem(FListStripInfo, SizeOf(TListStripInfo)*FCountStripInfo);
// Read StripOffsets and StripByteCounts into Information List
for TagLoop := 0 to FCountTag-1 do
begin
// Strip Byte Counts
if FListTag^[TagLoop].Tag = tiffTag_StripByteCounts then
begin
if FListTag^[TagLoop].Count = 1 then
begin
FListStripInfo^[0].StripByteCounts := FListTag^[TagLoop].Value;
end
else
begin
// Scan the file for the list of Strip Bytes Counts
FileSeek(AFileHandle,FListTag^[TagLoop].Value,0);
for I := 0 to FCountStripInfo-1 do
begin
FileRead(AFileHandle, FListStripInfo^[I].StripByteCounts, 4);
end;
end;
end;
// StripOffsets
if FListTag^[TagLoop].Tag = tiffTag_StripOffsets then
begin
if FListTag^[TagLoop].Count = 1 then
begin
FListStripInfo^[0].StripOffsets := FListTag^[TagLoop].Value;
end
else
begin
// Scan the file for the list of StripOffsets
FileSeek(AFileHandle,FListTag^[TagLoop].Value,0);
for I := 0 to FCountStripInfo-1 do
begin
FileRead(AFileHandle, FListStripInfo^[I].StripOffsets, 4);
end;
end;
end;
end;
end;
end;
// Read offset to the following IFD (or $00 00 00 00)
try
FileSeek(AFileHandle,FFilePosition,0);
FileRead(AFileHandle, FNextIFD, 4);
if not FFileTiff.LittleEndian then FNextIFD := SwapLongInt(FNextIFD);
except
FNextIFD := 0;
end;
except
FError:=True;
end;
end;
end;
(*---------------------------------------------------------------*)
constructor TGraphicTiff.Create(AFileTiff:TFileTiff);
begin
inherited Create;
FCountTag := 0;
FError := False;
FFileTiff := AFileTiff;
FListTag := nil;
FListStripInfo := nil;
FNextIFD := 0;
FCountStripInfo:= 0;
end;
(*---------------------------------------------------------------*)
(* return all IFD Tags as StringList
(*---------------------------------------------------------------*)
procedure TGraphicTiff.QueryGraphic(AStringList:TStringList);
var
TagLoop : Word;
begin
if Assigned(AStringList) then
begin
AStringList.Clear;
if FCountTag>0 then
begin
AStringList.Add(' Tag VarType Count Value');
AStringList.Add('=====================================');
for TagLoop:=0 to FCountTag-1 do
begin
with FListTag^[TagLoop] do
begin
AStringList.Add(' $'+IntToHex(Tag,4)+
' $'+IntToHex(VarType,4)+
' $'+IntToHex(Count,8)+
' $'+IntToHex(Value,8) )
end;
end;
end;
end;
end;
(*---------------------------------------------------------------*)
function TGraphicTiff.QueryGraphicByTag( TagId : Word ) : PTagTiff;
var
TagLoop : Word;
begin
Result := nil;
if FCountTag>0 then
begin
for TagLoop:=0 to FCountTag-1 do
begin
if FListTag^[TagLoop].Tag = TagId then
begin
Result := @FListTag^[TagLoop];
end;
end;
end;
end;
(*---------------------------------------------------------------*)
function TGraphicTiff.QueryGraphicByOffsets( OffsetId : Word ) : PStripInfo;
begin
Result := nil;
if FListStripInfo = nil then exit;
if OffsetId >= FCountStripInfo then exit;
if FCountStripInfo > 0 then
begin
Result := @FListStripInfo^[OffsetId];
end;
end;
(*---------------------------------------------------------------*)
function TGraphicTiff.GetNoOfOffsets : Word;
begin
Result := FCountStripInfo;
end;
(*---------------------------------------------------------------*)
destructor TGraphicTiff.Destroy;
begin
if FListTag<>nil then FreeMem(FListTag,SizeOf(TTagTiff)*FCountTag);
if FListStripInfo<>nil then FreeMem(FListStripInfo);
inherited Destroy;
end;
// ------------------------------------------------------------------
// Class containing image independent information
// ------------------------------------------------------------------
(*---------------------------------------------------------------*)
function TFileTiff.AddGraphicFromFile( AFileHandle : Integer;
AFileOffset : LongInt):TGraphicTiff;
var
NewGraphic : TGraphicTiff;
begin
NewGraphic := TGraphicTiff.Create(Self);
FileSeek(AFileHandle,AFileOffset,0); // Reset FilePointer
NewGraphic.LoadIFD(AFileHandle); // Read Image File Directory
FGraphicsList.Add(NewGraphic); // Add List of IFD Tags
AddGraphicFromFile := NewGraphic; // Return list of IFD Tags
end;
(*---------------------------------------------------------------*)
procedure TFileTiff.DeleteAll;
var
GraphicLoop : Integer;
begin
if FGraphicsList.Count>0 then
begin
for GraphicLoop:=0 to FGraphicsList.Count-1 do
TGraphicTiff(FGraphicsList.Items[GraphicLoop]).Free;
end;
FGraphicsList.Clear;
end;
(*---------------------------------------------------------------*)
function TFileTiff.GetGraphicCount:Integer;
begin
GetGraphicCount := FGraphicsList.Count;
end;
(*---------------------------------------------------------------*)
function TFileTiff.GetGraphicTiff(AGraphicID:Byte):TGraphicTiff;
begin
Result:=nil;
if (FGraphicsList.Count>0) and (AGraphicID<FGraphicsList.Count)
then Result:=TGraphicTiff(FGraphicsList.Items[AGraphicID]);
end;
(*---------------------------------------------------------------*)
procedure TFileTiff.SetFileName(AFileName:TFileName);
var
TiffHandle:Integer;
SearchFile:TSearchRec;
HeaderTiff:THeaderTiff;
GraphicTiff:TGraphicTiff;
begin
// if it does not exists create it
if not FileExists(AFileName) and (AFileName<>'') then
begin
TiffHandle := FileCreate(AFileName);
if TiffHandle>-1 then
begin
if LittleEndian
then HeaderTiff.Endian := tiffLittleEndian
else HeaderTiff.Endian := tiffBigEndian;
HeaderTiff.Confirm := tiffConfirm;
if not LittleEndian then HeaderTiff.Confirm := Swap(HeaderTiff.Confirm);
HeaderTiff.FirstIFD:=0;
FileWrite(TiffHandle,HeaderTiff,SizeOf(THeaderTiff));
FileClose(TiffHandle);
end;
end;
// Try to Read Tiff Image
if (AFileName<>'') and (AFileName<>FFileName) then
begin
DeleteAll;
FValid := False;
SysUtils.FindFirst(AFileName,faAnyFile,SearchFile);
FFileSize:=SearchFile.Size;
SysUtils.FindClose(SearchFile);
if FFileSize>=SizeOf(THeaderTiff) then
begin
TiffHandle := FileOpen(AFileName,fmShareDenyNone);
// Read Header
FileRead(TiffHandle,HeaderTiff,SizeOf(THeaderTiff));
FValid := True;
if HeaderTiff.Endian=tiffLittleEndian then
begin
FLittleEndian:=True;
end
else
begin
if HeaderTiff.Endian=tiffBigEndian then
begin
FLittleEndian:=False;
end
else FValid:=False;
end;
// Header is a valid Tiff Header
if FValid then
begin
if not FLittleEndian then
begin
HeaderTiff.Confirm := Swap(HeaderTiff.Confirm);
HeaderTiff.FirstIFD := SwapLongInt(HeaderTiff.FirstIFD);
end;
if HeaderTiff.Confirm<>tiffConfirm then FValid:=False;
end;
// Header is a valid Tiff Header. Try to read IFD
FFileName:=AFileName;
if HeaderTiff.FirstIFD >= SizeOf(THeaderTiff) then
begin
// read Graphic Information of first image
GraphicTiff := AddGraphicFromFile(TiffHandle,HeaderTiff.FirstIFD);
// if present: read Graphic Information of all following images
while (GraphicTiff.NextIFD>=SizeOf(THeaderTiff)) do
GraphicTiff:=AddGraphicFromFile(TiffHandle,GraphicTiff.NextIFD);
end;
FileClose(TiffHandle);
end;
end
else
begin
if AFileName='' then
begin
// Reinitialization
DeleteAll;
FFileName := '';
FFileSize := 0;
FValid := False;
end;
end;
end;
(*---------------------------------------------------------------*)
constructor TFileTiff.Create;
begin
inherited Create;
FFileName := '';
FFileSize := 0;
FGraphicsList := TList.Create;
FLittleEndian := True;
FValid := False;
end;
(*---------------------------------------------------------------*)
procedure TFileTiff.DeleteGraphic(AGraphicID:Byte);
begin
if (FGraphicsList.Count>0) and (AGraphicID<FGraphicsList.Count) then
begin
TGraphicTiff(FGraphicsList).Free;
FGraphicsList.Delete(AGraphicID);
FGraphicsList.Pack;
end;
end;
(*---------------------------------------------------------------*)
procedure TFileTiff.ExchangeGraphic(AIndex1, AIndex2 : Byte);
begin
if (FGraphicsList.Count > 0) and
(AIndex1 < FGraphicsList.Count) and
(AIndex2 < FGraphicsList.Count)
then FGraphicsList.Exchange(AIndex1, AIndex2);
end;
(*---------------------------------------------------------------*)
destructor TFileTiff.Destroy;
begin
DeleteAll;
FGraphicsList.Free;
inherited Destroy;
end;
end.
unit ReadTiff;
(*
10.10.1998: started with code of Jean Marc CARAYON and Daniel DROUIN, France
14.10.1998: Uncompressed Palette Image added by Wolfgang Krug
15.10.1998: Uncompressed Bilevel Image added by Wolfgang Krug
15.10.1998: Uncompressed Gray Scale Image added by Wolfgang Krug
15.10.1998: Uncompressed RGB Full Color Image added by Wolfgang Krug
*)
interface
uses Windows, SysUtils, Graphics, Dialogs, ReadTiffTags;
Type
ColorTableRed = array [0..256] of Word;
ColorTableGreen = array [0..256] of Word;
ColorTableBlue = array [0..256] of Word;
// File format functions
procedure LoadTiffFromFile (FileName : string; Bitmap : TBitmap);
procedure TIFFBilevelImage (FileName : string; GraphTiff : TGraphicTiff; var Bitmap : TBitmap);
procedure TIFFGrayScaleImage (FileName : string; GraphTiff : TGraphicTiff; var Bitmap : TBitmap);
procedure TIFFColorPaletImage (FileName : string; GraphTiff : TGraphicTiff; var Bitmap : TBitmap);
procedure TIFFRGBFullColorImage(FileName : string; GraphTiff : TGraphicTiff; var Bitmap : TBitmap);
// Internal Functions
procedure InitColTab;
procedure CreateGreyColTab( BitsPerSample : Integer);
procedure CreateBilevelColTab( White : Integer);
procedure ReadColTabFromFile( AFileName : string;
ACounter : LongInt;
AFileOffset : LongInt);
function ReadImageDataFromFile(AFileName : string;
var AImageBuffer : PChar;
AGraphTiff : TGraphicTiff):Integer;
procedure AlignBmpRows(var AImageBuffer : PChar; AGraphTiff : TGraphicTiff);
procedure ReadBitsPerSampleColor(AFileName : string;
AFileOffset : LongInt;
var BPSRed : Integer;
var BPSGreen : Integer;
var BPSBlue : Integer);
procedure DisplayImage(width : Word; height : Word;
BitCount : Word; buff : PChar;
Bitmap : TBitmap);
var
FColorTableRed : ColorTableRed;
FColorTableGreen : ColorTableGreen;
FColorTableBlue : ColorTableBlue;
implementation
uses Unit1;
//
// Internal Functions
//
(*---------------------------------------------------------------*)
procedure InitColTab;
var
I : Integer;
begin
// create Color Table of 256 shades of grey
for I:=0 to 255 do begin
FColorTableRed[I] := Word(I);
FColorTableGreen[I] := Word(I);
FColorTableBlue[I] := Word(I);
end;
end;
(*---------------------------------------------------------------*)
procedure CreateGreyColTab( BitsPerSample : Integer);
var
I : Integer;
begin
InitColTab;
if BitsPerSample = 4 then
begin
for I:=0 to 15 do begin
FColorTableRed[I] := Word(I * 255 div 15);
FColorTableGreen[I] := Word(I * 255 div 15);
FColorTableBlue[I] := Word(I * 255 div 15);
end;
end;
end;
(*---------------------------------------------------------------*)
procedure CreateBilevelColTab( White : Integer);
begin
InitColTab;
if White = 1 then
begin
FColorTableRed[0] := 0;
FColorTableGreen[0] := 0;
FColorTableBlue[0] := 0;
FColorTableRed[1] := 255;
FColorTableGreen[1] := 255;
FColorTableBlue[1] := 255;
end
else
begin
FColorTableRed[0] := 255;
FColorTableGreen[0] := 255;
FColorTableBlue[0] := 255;
FColorTableRed[1] := 0;
FColorTableGreen[1] := 0;
FColorTableBlue[1] := 0;
end;
end;
(*---------------------------------------------------------------*)
procedure ReadColTabFromFile( AFileName : string;
ACounter : LongInt;
AFileOffset : LongInt);
var
TiffHandle : Integer;
I : Integer;
begin
InitColTab;
ACounter := ACounter div 3;
if ACounter < 1 then exit;
if ACounter > 256 then exit;
TiffHandle := FileOpen(AFileName, fmShareDenyNone);
// read Color Table from file
FileSeek(TiffHandle, AFileOffset, 0);
FileRead(TiffHandle, FColorTableRed, ACounter*SizeOf(Word));
FileRead(TiffHandle, FColorTableGreen, ACounter*SizeOf(Word));
FileRead(TiffHandle, FColorTableBlue, ACounter*SizeOf(Word));
for I:=0 to ACounter do begin
FColorTableRed[I] := FColorTableRed[I] div 256;
FColorTableGreen[I] := FColorTableGreen[I] div 256;
FColorTableBlue[I] := FColorTableBlue[I] div 256;
end;
FileClose(TiffHandle);
end;
(*---------------------------------------------------------------*)
function ReadImageDataFromFile( AFileName : string;
var AImageBuffer : PChar;
AGraphTiff : TGraphicTiff) : Integer;
var
ImageSize : LongInt;
TiffHandle : Integer;
PStrpInfo : PStripInfo;
I : Integer;
BuffPtr : PChar;
Count : Integer;
Begin
Result := 0;
// Prepare Data buffer
ImageSize := 0;
for I:=0 to AGraphTiff.GetNoOfOffsets-1 do
begin
PStrpInfo := AGraphTiff.QueryGraphicByOffsets(I);
if PStrpInfo <> nil then
ImageSize := ImageSize + PStrpInfo^.StripByteCounts;
end;
GetMem(AImageBuffer, ImageSize);
BuffPtr := AImageBuffer;
TiffHandle := FileOpen(AFileName, fmShareDenyNone);
// Read Image Data
for I:=0 to AGraphTiff.GetNoOfOffsets-1 do
begin
PStrpInfo := AGraphTiff.QueryGraphicByOffsets(I);
if PStrpInfo <> nil then
begin
FileSeek(TiffHandle, PStrpInfo^.StripOffsets, 0);
Count := FileRead(TiffHandle, BuffPtr^, PStrpInfo^.StripByteCounts);
BuffPtr := BuffPtr + PStrpInfo^.StripByteCounts;
if Count <> PStrpInfo^.StripByteCounts then
begin
Result := 1;
FreeMem(AImageBuffer, ImageSize);
exit;
end;
end;
end;
FileClose(TiffHandle);
end;
(*---------------------------------------------------------------*)
procedure AlignBmpRows(var AImageBuffer : PChar; AGraphTiff : TGraphicTiff);
var
PTag : PTagTiff;
PStrpInfo : PStripInfo;
ImageHeight : LongInt;
RowsPerStrip : LongInt;
RowLength : LongInt;
AlignedRowLength : LongInt;
TargetBuffer : PChar;
TargetBufPtr : PChar;
SourceBufPtr : PChar;
I : Integer;
begin
// Keep in mind: The rows of a Bitmap are DWORD aligned !!!
PStrpInfo := AGraphTiff.QueryGraphicByOffsets(0);
// Read Image Height
PTag := AGraphTiff.QueryGraphicByTag( tiffTag_ImageLength );
ImageHeight := PTag^.Value;
// Read Rows Per Strip
PTag := AGraphTiff.QueryGraphicByTag( tiffTag_RowsPerStrip );
RowsPerStrip := PTag^.Value;
RowLength := PStrpInfo^.StripByteCounts div RowsPerStrip;
AlignedRowLength := ((RowLength+3) div 4) * 4;
if RowLength <> AlignedRowLength then
begin
GetMem(TargetBuffer, AlignedRowLength*ImageHeight);
SourceBufPtr := AImageBuffer;
TargetBufPtr := TargetBuffer;
for I:=0 to ImageHeight-1 do
begin
CopyMemory(TargetBufPtr, SourceBufPtr, RowLength*SizeOf(Byte));
SourceBufPtr := SourceBufPtr + RowLength;
TargetBufPtr := TargetBufPtr + AlignedRowLength;
end;
FreeMem(AImageBuffer);
AImageBuffer := TargetBuffer;
end;
end;
(*---------------------------------------------------------------*)
procedure ReadBitsPerSampleColor(AFileName : string;
AFileOffset : LongInt;
var BPSRed : Integer;
var BPSGreen : Integer;
var BPSBlue : Integer);
var
TiffHandle : Integer;
begin
// Read Bits per sample for Red green and Blue Color
TiffHandle := FileOpen(AFileName, fmShareDenyNone);
FileSeek(TiffHandle, AFileOffset, 0);
FileRead(TiffHandle, BPSRed, 2);
FileRead(TiffHandle, BPSGreen, 2);
FileRead(TiffHandle, BPSBlue, 2);
FileClose(TiffHandle);
end;
(*---------------------------------------------------------------*)
procedure ExchangeRedAndBlue(var AImageBuffer : PChar; Size : LongInt);
var
Bits : PChar;
BitsPtr : PChar;
I : LongInt;
Red, Blue : Char;
begin
// Keep in mind: The RGB-Pixels of a Bitmap are ordered BGR !!!
BitsPtr := AImageBuffer;
for I:=0 to Size-1 do
begin
Blue := (BitsPtr)^ ;
Red := (BitsPtr+2)^;
(BitsPtr)^ := Red;
(BitsPtr+2)^ := Blue;
BitsPtr := BitsPtr + 3;
end;
end;
(*---------------------------------------------------------------*)
procedure DisplayImage(width : Word; height : Word;
BitCount : Word; buff: PChar;
Bitmap : TBitmap);
var
I : Integer;
hBmp : HBITMAP;
BI : PBitmapInfo;
BIH : TBitmapInfoHeader;
Bmp : TBitmap;
ImagoDC : hDC;
begin
// Fill BitmapInfoHeader structure
BIH.biSize := Sizeof(BIH);
BIH.biWidth := width;
BIH.biHeight := -height;
BIH.biPlanes := 1;
BIH.biBitCount := BitCount;
BIH.biCompression := BI_RGB;
BIH.biSizeImage := 0;
BIH.biXPelsPerMeter := 0;
BIH.biYPelsPerMeter := 0;
BIH.biClrUsed := 0;
BIH.biClrImportant := 0;
{$P+,S-,W-,R-}
// Create DIB Bitmap Info with actual color table
BI := AllocMem(SizeOf(TBitmapInfoHeader) + 256*Sizeof(TRGBQuad));
try
BI^.bmiHeader := BIH;
for I:=0 to 255 do begin
BI^.bmiColors[I].rgbBlue := Byte(FColorTableBlue[I]);
BI^.bmiColors[I].rgbGreen := Byte(FColorTableGreen[I]);
BI^.bmiColors[I].rgbRed := Byte(FColorTableRed[I]);
BI^.bmiColors[I].rgbReserved := 0;
end;
Bitmap.Assign( nil ); // Clear actual Image
Bmp := TBitmap.Create;
Bmp.Height := width;
Bmp.Width := height;
ImagoDC := GetDC(Bitmap.Handle);
hBmp := CreateDIBitmap(
ImagoDC, // handle of device context
BIH, // address of bitmap size and format data
CBM_INIT, // initialization flag
buff, // address of initialization data
BI^, // address of bitmap color-format data
DIB_RGB_COLORS ); // color-data usage
Bmp.Handle := hBmp;
Bitmap.Assign( Bmp );
Bmp.Free;
except
showmessage('Out Of Memory ');
exit;
end;
FreeMem( BI, SizeOf(TBitmapInfoHeader) + 256*Sizeof(TRGBQuad));
{$P-,S+,W+,R+}
end;
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
(*-- Main Function: Load TIFF File and determine type of image --*)
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
procedure LoadTiffFromFile(FileName : string; Bitmap : TBitmap);
var
TiffFile : TFileTiff;
GraphTiff : TGraphicTiff;
I : Integer;
PTag : PTagTiff;
PhotometricInterpretation : LongInt;
BitsPerSample : LongInt;
begin
TiffFile := TFileTiff.Create;
TiffFile.FileName := FileName;
if NOT TiffFile.Valid then
begin
showmessage('<'+FileName+'> is not a valid TIFF file');
TiffFile.Free;
exit;
end;
// Go over all images within the TIFF file
for I := 0 to TiffFile.GraphicCount-1 do
begin
GraphTiff := TiffFile.GetGraphicTiff(I);
//
// Check the type of image
//
// Read Photometric interpretation
PTag := GraphTiff.QueryGraphicByTag( tiffTag_PhotometricInterpretation );
if PTag = nil then
begin
showmessage('Error reading tag Photometric interpretation');
TiffFile.Free;
exit;
end;
PhotometricInterpretation := PTag^.Value;
// Photometric interpretation should be:
// 0, 1 = Bilevel Image
// 2 = Palette color image
// 3 = RGB Full Color Image
if (PhotometricInterpretation < 0) or
(PhotometricInterpretation > 3) then
begin
showmessage('Error evaluating Photometric interpretation: '+IntToStr(PhotometricInterpretation));
TiffFile.Free;
exit;
end;
// Bilevel Image or Grayscale Image
if (PhotometricInterpretation = 0) or (PhotometricInterpretation = 1) then
begin
// Read Bits Per Sample
PTag := GraphTiff.QueryGraphicByTag( tiffTag_BitsPerSample );
if PTag = nil then
begin
TIFFBilevelImage(TiffFile.FileName, GraphTiff, Bitmap);
end
else
begin
BitsPerSample := PTag^.Value;
if BitsPerSample = 1 then
begin
TIFFBilevelImage(TiffFile.FileName, GraphTiff, Bitmap);
end
else
begin
if (BitsPerSample = 4) or (BitsPerSample = 8) then
begin
TIFFGrayScaleImage(TiffFile.FileName, GraphTiff, Bitmap);
end;
end;
end;
end;
// Color Palette Image
if (PhotometricInterpretation = 3) then
begin
TIFFColorPaletImage(TiffFile.FileName, GraphTiff, Bitmap);
end;
// RGB Full Color Image
if (PhotometricInterpretation = 2) then
begin
TIFFRGBFullColorImage(TiffFile.FileName, GraphTiff, Bitmap);
end;
end;
TiffFile.Free;
end;
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
(*--- Bilevel Image ---*)
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
procedure TIFFBilevelImage(FileName : string; GraphTiff : TGraphicTiff; var Bitmap : TBitmap);
var
PTag : PTagTiff;
ImageWidth : LongInt;
ImageHeight : LongInt;
Compression : LongInt;
PhotometricInterpretation : LongInt;
ImageBuffer : PChar;
begin
// Read Image Width
PTag := GraphTiff.QueryGraphicByTag( tiffTag_ImageWidth );
if PTag = nil then
begin
showmessage('Error reading tag Image Width');
exit;
end;
ImageWidth := PTag^.Value;
// Read Image Height
PTag := GraphTiff.QueryGraphicByTag( tiffTag_ImageLength );
if PTag = nil then
begin
showmessage('Error reading tag Image Height');
exit;
end;
ImageHeight := PTag^.Value;
// Read Photometric interpretation
PTag := GraphTiff.QueryGraphicByTag( tiffTag_PhotometricInterpretation );
if PTag = nil then
begin
showmessage('Error reading tag Photometric interpretation');
exit;
end;
PhotometricInterpretation := PTag^.Value;
// Read Compression
PTag := GraphTiff.QueryGraphicByTag( tiffTag_Compression );
if PTag = nil then
begin
showmessage('Error reading tag Compression');
exit;
end;
Compression := PTag^.Value;
// 1 = No Compression
// 2 = CCITT Group 3 (1-Dimensional Modified Huffman run length encoding)
// 32773 = PxckBits compression, a simple byte-oriented run length scheme.
if Compression = 1 then // NO Compression
begin
CreateBilevelColTab( PhotometricInterpretation );
// Read Image Data
if ReadImageDataFromFile( FileName, ImageBuffer, GraphTiff) = 0 then
begin
AlignBmpRows(ImageBuffer, GraphTiff);
DisplayImage(ImageWidth, ImageHeight, 1, ImageBuffer, Bitmap);
FreeMem(ImageBuffer);
end
else
begin
showmessage('Error reading image data');
end;
end
else
begin
showmessage('Cant read compressed bilevel image'+#13+#13+
'feel free to implement this type of image'+#13+
'and send it back to krug@sdm.de');
exit;
end;
end;
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
(*--- Gray Scale Image ---*)
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
procedure TIFFGrayScaleImage (FileName : string; GraphTiff : TGraphicTiff; var Bitmap : TBitmap);
var
PTag : PTagTiff;
ImageWidth : LongInt;
ImageHeight : LongInt;
Compression : LongInt;
BitsPerSample : LongInt;
ImageBuffer : PChar;
begin
// Read Image Width
PTag := GraphTiff.QueryGraphicByTag( tiffTag_ImageWidth );
if PTag = nil then
begin
showmessage('Error reading tag Image Width');
exit;
end;
ImageWidth := PTag^.Value;
// Read Image Height
PTag := GraphTiff.QueryGraphicByTag( tiffTag_ImageLength );
if PTag = nil then
begin
showmessage('Error reading tag Image Height');
exit;
end;
ImageHeight := PTag^.Value;
// Read Compression
PTag := GraphTiff.QueryGraphicByTag( tiffTag_Compression );
if PTag = nil then
begin
showmessage('Error reading tag Compression');
exit;
end;
Compression := PTag^.Value;
// 1 = No Compression
// 2 = CCITT Group 3 (1-Dimensional Modified Huffman run length encoding)
// 32773 = PxckBits compression, a simple byte-oriented run length scheme.
if Compression = 1 then // NO Compression
begin
// Read Bits Per Sample
PTag := GraphTiff.QueryGraphicByTag( tiffTag_BitsPerSample );
if PTag = nil then
begin
showmessage('Error reading tag Bits Per Sample');
exit;
end;
BitsPerSample := PTag^.Value;
// Check Value of BitsPerSample
if (BitsPerSample <> 4) and (BitsPerSample <> 8) then
begin
showmessage('Error: Bits Per Sample not 4 or 8');
exit;
end;
CreateGreyColTab( BitsPerSample );
// Read Image Data
if ReadImageDataFromFile( FileName, ImageBuffer, GraphTiff) = 0 then
begin
AlignBmpRows(ImageBuffer, GraphTiff);
DisplayImage(ImageWidth, ImageHeight, BitsPerSample, ImageBuffer, Bitmap);
FreeMem(ImageBuffer);
end
else
begin
showmessage('Error reading image data');
end;
end
else
begin
showmessage('Cant read compressed Gray Scale Image'+#13+#13+
'feel free to implement this type of image'+#13+
'and send it back to krug@sdm.de');
end;
end;
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
(*--- Color Palet Image ---*)
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
procedure TIFFColorPaletImage(FileName : string; GraphTiff : TGraphicTiff; var Bitmap : TBitmap);
var
PTag : PTagTiff;
ImageWidth : LongInt;
ImageHeight : LongInt;
Compression : LongInt;
BitsPerSample : LongInt;
ImageBuffer : PChar;
begin
// Read Image Width
PTag := GraphTiff.QueryGraphicByTag( tiffTag_ImageWidth );
if PTag = nil then
begin
showmessage('Error reading tag Image Width');
exit;
end;
ImageWidth := PTag^.Value;
// Read Image Height
PTag := GraphTiff.QueryGraphicByTag( tiffTag_ImageLength );
if PTag = nil then
begin
showmessage('Error reading tag Image Height');
exit;
end;
ImageHeight := PTag^.Value;
// Read Compression
PTag := GraphTiff.QueryGraphicByTag( tiffTag_Compression );
if PTag = nil then
begin
showmessage('Error reading tag Compression');
exit;
end;
Compression := PTag^.Value;
// 1 = No Compression
// 2 = CCITT Group 3 (1-Dimensional Modified Huffman run length encoding)
// 32773 = PxckBits compression, a simple byte-oriented run length scheme.
if Compression = 1 then // NO Compression
begin
// Read Bits Per Sample
PTag := GraphTiff.QueryGraphicByTag( tiffTag_BitsPerSample );
if PTag = nil then
begin
showmessage('Error reading tag Bits Per Sample');
exit;
end;
BitsPerSample := PTag^.Value;
// read Color Table Offset
PTag := GraphTiff.QueryGraphicByTag( tiffTag_ColorMapOffset );
if PTag = nil then
begin
showmessage('Error reading tag Color Table Offset');
exit;
end;
ReadColTabFromFile( FileName, PTag^.Count, PTag^.Value);
// Read Image Data
if ReadImageDataFromFile( FileName, ImageBuffer, GraphTiff) = 0 then
begin
AlignBmpRows(ImageBuffer, GraphTiff);
DisplayImage(ImageWidth, ImageHeight, BitsPerSample, ImageBuffer, Bitmap);
FreeMem(ImageBuffer);
end
else
begin
showmessage('Error reading image data');
end;
end
else
begin
showmessage('Cant read compressed ColorPaletImage'+#13+#13+
'feel free to implement this type of image'+#13+
'and send it back to krug@sdm.de');
end;
end;
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
(*--- RGB Full Color Image ---*)
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
procedure TIFFRGBFullColorImage(FileName : string; GraphTiff : TGraphicTiff; var Bitmap : TBitmap);
var
PTag : PTagTiff;
ImageWidth : LongInt;
ImageHeight : LongInt;
Compression : LongInt;
BitsPerSampleRed : Integer;
BitsPerSampleGreen : Integer;
BitsPerSampleBlue : Integer;
ImageBuffer : PChar;
begin
// Read Image Width
PTag := GraphTiff.QueryGraphicByTag( tiffTag_ImageWidth );
if PTag = nil then
begin
showmessage('Error reading tag Image Width');
exit;
end;
ImageWidth := PTag^.Value;
// Read Image Height
PTag := GraphTiff.QueryGraphicByTag( tiffTag_ImageLength );
if PTag = nil then
begin
showmessage('Error reading tag Image Height');
exit;
end;
ImageHeight := PTag^.Value;
// Read Compression
PTag := GraphTiff.QueryGraphicByTag( tiffTag_Compression );
if PTag = nil then
begin
showmessage('Error reading tag Compression');
exit;
end;
Compression := PTag^.Value;
// 1 = No Compression
// 2 = CCITT Group 3 (1-Dimensional Modified Huffman run length encoding)
// 32773 = PxckBits compression, a simple byte-oriented run length scheme.
if Compression = 1 then // NO Compression
begin
// Read Bits Per Sample
PTag := GraphTiff.QueryGraphicByTag( tiffTag_BitsPerSample );
if PTag = nil then
begin
showmessage('Error reading tag Bits Per Sample');
exit;
end;
if PTag^.Count = 1 then
begin
BitsPerSampleRed := PTag^.Value;
BitsPerSampleGreen := PTag^.Value;
BitsPerSampleBlue := PTag^.Value;
end
else
begin
ReadBitsPerSampleColor(FileName, PTag^.Value,
BitsPerSampleRed, BitsPerSampleGreen, BitsPerSampleBlue);
end;
if (BitsPerSampleRed <> 8) and
(BitsPerSampleGreen <> 8) and
(BitsPerSampleBlue <> 8) then
begin
showmessage('Error: Bits Per Sample (RGB) not 8');
exit;
end;
// Read Image Data
if ReadImageDataFromFile( FileName, ImageBuffer, GraphTiff) = 0 then
begin
ExchangeRedAndBlue(ImageBuffer, ImageWidth*ImageHeight);
AlignBmpRows(ImageBuffer, GraphTiff);
DisplayImage(ImageWidth, ImageHeight, 24, ImageBuffer, Bitmap);
FreeMem(ImageBuffer);
end
else
begin
showmessage('Error reading image data');
end;
end
else
begin
showmessage('Cant read compressed RGB Full Color Image'+#13+#13+
'feel free to implement this type of image'+#13+
'and send it back to krug@sdm.de');
end;
end;
end.
uses ReadTiff
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
LoadTiffFromFile(OpenDialog1.FileName, Image1.Picture.Bitmap);
Image1.Picture.Bitmap.SaveToFile(OpenDialog1.FileName + '.bmp');
Image1.Refresh;
end;
end;
Keine Kommentare:
Kommentar veröffentlichen