Convert Image di Delphi

unit ads_GraphicConversion; {
Copyright(c)2001 Advanced Delphi Systems (Richard Maley,12613 Maidens Bower Drive, Potomac, MD 20854 USA, phone 301-840-1554, maley@advdelphisys.com, http://www.advdelphisys.com/)

The code herein can be used or modified by anyone. Please retain references to Dick Maley at Advanced Delphi Systems. If you make improvements to the code please send your improvements to maley@advdelphisys.com so that the entire Delphi community can benefit. All comments are welcome.

}

interface
Uses
Windows,WinProcs,WinTypes, Graphics, Classes, Jpeg, {}GifImage{};

Function BitmapToGif(Bitmap: TBitmap;Gif: TGifImage): Boolean; Overload;
Function BitmapToGif(BitmapFile,GifFile: String): Boolean; Overload;
Function BitmapToGif(BitmapFile,GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Function BitmapToGif(BitmapFile: String): Boolean; Overload;
Function BitmapToGif(BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Function BitmapToJPeg(Bitmap: TBitmap;Jpeg: TJpegImage): Boolean; Overload;
Function BitmapToJPeg(BitmapFile,JpegFile: String): Boolean; Overload;
Function BitmapToJPeg(BitmapFile,JpegFile: String; DeleteSource: Boolean): Boolean; Overload;
Function BitmapToJPeg(BitmapFile: String): Boolean; Overload;
Function BitmapToJPeg(BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Function BitmapToTiff(Bitmap: TBitmap;Stream: TStream): Boolean; Overload;
Function BitmapToTiff(Bitmap: TBitmap;TiffFile: String): Boolean; Overload;
Function BitmapToTiff(BitmapFile,TiffFile: String): Boolean; Overload;
Function BitmapToTiff(BitmapFile,TiffFile: String; DeleteSource: Boolean): Boolean; Overload;
Function BitmapToTiff(BitmapFile: String): Boolean; Overload;
Function BitmapToTiff(BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Function GifToBitmap(Gif: TGifImage;Bitmap: TBitmap): Boolean; Overload;
Function GifToBitmap(GifFile,BitmapFile: String): Boolean; Overload;
Function GifToBitmap(GifFile,BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Function GifToBitmap(GifFile: String): Boolean; Overload;
Function GifToBitmap(GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Function GifToJPeg(Gif: TGifImage;Jpeg: TJpegImage): Boolean; Overload;
Function GifToJPeg(GifFile,JpegFile: String): Boolean; Overload;
Function GifToJPeg(GifFile,JpegFile: String; DeleteSource: Boolean): Boolean; Overload;
Function GifToJPeg(GifFile: String): Boolean; Overload;
Function GifToJPeg(GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Function GifToTiff(Gif: TGifImage;Stream: TStream): Boolean; Overload;
Function GifToTiff(Gif: TGifImage;TiffFile: String): Boolean; Overload;
Function GifToTiff(GifFile,TiffFile: String): Boolean; Overload;
Function GifToTiff(GifFile,TiffFile: String; DeleteSource: Boolean): Boolean; Overload;
Function GifToTiff(GifFile: String): Boolean; Overload;
Function GifToTiff(GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Function JPegToBitmap(Jpeg: TJpegImage;Bitmap: TBitmap): Boolean; Overload;
Function JPegToBitmap(JpegFile,BitmapFile: String): Boolean; Overload;
Function JPegToBitmap(JpegFile,BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Function JPegToBitmap(JpegFile: String): Boolean; Overload;
Function JPegToBitmap(JpegFile: String; DeleteSource: Boolean): Boolean; Overload;
Function JpegToGif(Jpeg: TJpegImage;Gif: TGifImage): Boolean; Overload;
Function JpegToGif(JpegFile,GifFile: String): Boolean; Overload;
Function JpegToGif(JpegFile,GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Function JpegToGif(JpegFile: String): Boolean; Overload;
Function JpegToGif(JpegFile: String; DeleteSource: Boolean): Boolean; Overload;
Function JpegToTiff(Jpeg: TJpegImage;Stream: TStream): Boolean; Overload;
Function JpegToTiff(Jpeg: TJpegImage;TiffFile: String): Boolean; Overload;
Function JpegToTiff(JpegFile,TiffFile: String): Boolean; Overload;
Function JpegToTiff(JpegFile,TiffFile: String; DeleteSource: Boolean): Boolean; Overload;
Function JpegToTiff(JpegFile: String): Boolean; Overload;
Function JpegToTiff(JpegFile: String; DeleteSource: Boolean): Boolean; Overload;

implementation

Uses
SysUtils;

Function JPegToBitmap(Jpeg: TJpegImage;Bitmap: TBitmap): Boolean;
Begin
Try
Bitmap.Assign(JPeg);
Result := True;
Except
Result := False;
End;
End;

Function JPegToBitmap(JpegFile,BitmapFile: String): Boolean; Overload;
Var
Bitmap : TBitmap;
Jpeg : TJpegImage;
Begin
Result := False;
If Not FileExists(JpegFile) Then Exit;
Bitmap := TBitmap.Create();
Jpeg := TJpegImage.Create();
Try
Try
Jpeg.LoadFromFile(JpegFile);
Result := JPegToBitmap(Jpeg,Bitmap);
If Result Then
Begin
If FileExists(BitmapFile) Then DeleteFile(BitmapFile);
Bitmap.SaveToFile(BitmapFile);
End;
Except
Result := False;
End;
Finally
Bitmap.Free;
Jpeg .Free;
End;
End;

Function JPegToBitmap(JpegFile: String; DeleteSource: Boolean): Boolean; Overload;
Var
FileExtOld : String;
FileExtNew : String;
FileNew : String;
FileOld : String;
Begin
FileOld := JpegFile;
FileExtNew := '.bmp';
Result := False;
If Not FileExists(FileOld) Then Exit;
FileExtOld := ExtractFileExt(FileOld);
FileNew := Copy(FileOld,1,Length(FileOld)-Length(FileExtOld))+FileExtNew;
Result := JPegToBitmap(FileOld,FileNew);
If DeleteSource Then If Result Then If FileExists(FileOld) Then DeleteFile(FileOld);
End;

Function JPegToBitmap(JpegFile: String): Boolean; Overload;
Begin
Result := JPegToBitmap(JpegFile, True);
End;

Function JPegToBitmap(JpegFile,BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Result := JPegToBitmap(JpegFile,BitmapFile);
If DeleteSource Then
Begin
If FileExists(JpegFile) Then DeleteFile(JpegFile);
Result := Not FileExists(JpegFile);
End;
End;

Function BitmapToJPeg(BitmapFile,JpegFile: String): Boolean; Overload;
Var
Bitmap : TBitmap;
Jpeg : TJpegImage;
Begin
Result := False;
If Not FileExists(BitmapFile) Then Exit;
Bitmap := TBitmap.Create();
Jpeg := TJpegImage.Create();
Try
Try
Bitmap.LoadFromFile(BitmapFile);
Result := BitmapToJPeg(Bitmap,Jpeg);
If Result Then
Begin
If FileExists(JpegFile) Then DeleteFile(JpegFile);
Jpeg.SaveToFile(JpegFile);
End;
Except
Result := False;
End;
Finally
Bitmap.Free;
Jpeg .Free;
End;
End;

Function BitmapToJPeg(Bitmap: TBitmap;Jpeg: TJpegImage): Boolean;
Begin
Try
Jpeg.Assign(Bitmap);
Result := True;
Except
Result := False;
End;
End;

Function BitmapToJPeg(BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Var
FileExtOld : String;
FileExtNew : String;
FileNew : String;
FileOld : String;
Begin
FileOld := BitmapFile;
FileExtNew := '.jpg';
Result := False;
If Not FileExists(FileOld) Then Exit;
FileExtOld := ExtractFileExt(FileOld);
FileNew := Copy(FileOld,1,Length(FileOld)-Length(FileExtOld))+FileExtNew;
Result := BitmapToJpeg(FileOld,FileNew);
If DeleteSource Then If Result Then If FileExists(FileOld) Then DeleteFile(FileOld);
End;

Function BitmapToJPeg(BitmapFile: String): Boolean; Overload;
Begin
Result := BitmapToJPeg(BitmapFile, True);
End;

Function BitmapToJPeg(BitmapFile,JpegFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Result := BitmapToJPeg(BitmapFile,JpegFile);
If DeleteSource Then
Begin
If FileExists(BitmapFile) Then DeleteFile(BitmapFile);
Result := Not FileExists(BitmapFile);
End;
End;

Function GifToBitmap(Gif: TGifImage;Bitmap: TBitmap): Boolean;
begin
Result := False;
If Gif = nil Then Exit;
Try
Bitmap.Assign(Gif.Bitmap);
Result := True;
Except
Result := False;
End;
end;

Function GifToBitmap(GifFile,BitmapFile: String): Boolean; Overload;
Var
Bitmap : TBitmap;
Gif : TGifImage;
Begin
Result := False;
If Not FileExists(GifFile) Then Exit;
Bitmap := TBitmap.Create();
Gif := TGifImage.Create();
Try
Try
Gif.LoadFromFile(GifFile);
Result := GifToBitmap(Gif,Bitmap);
If Result Then
Begin
If FileExists(BitmapFile) Then DeleteFile(BitmapFile);
Bitmap.SaveToFile(BitmapFile);
End;
Except
Result := False;
End;
Finally
Bitmap.Free;
Gif .Free;
End;
End;

Function GifToBitmap(GifFile,BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Result := GifToBitmap(GifFile,BitmapFile);
If DeleteSource Then
Begin
If FileExists(GifFile) Then DeleteFile(GifFile);
Result := Not FileExists(GifFile);
End;
End;

Function GifToBitmap(GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Var
FileExtOld : String;
FileExtNew : String;
FileNew : String;
FileOld : String;
Begin
FileOld := GifFile;
FileExtNew := '.bmp';
Result := False;
If Not FileExists(FileOld) Then Exit;
FileExtOld := ExtractFileExt(FileOld);
FileNew := Copy(FileOld,1,Length(FileOld)-Length(FileExtOld))+FileExtNew;
Result := GifToBitmap(FileOld,FileNew);
If DeleteSource Then If Result Then If FileExists(FileOld) Then DeleteFile(FileOld);
End;

Function GifToBitmap(GifFile: String): Boolean; Overload;
Begin
Result := GifToBitmap(GifFile, True);
End;

Function BitmapToGif(BitmapFile,GifFile: String): Boolean; Overload;
Var
Bitmap : TBitmap;
Gif : TGifImage;
Begin
Result := False;
If Not FileExists(BitmapFile) Then Exit;
Bitmap := TBitmap.Create();
Gif := TGifImage.Create();
Try
Try
Bitmap.LoadFromFile(BitmapFile);
Result := BitmapToGif(Bitmap,Gif);
If Result Then
Begin
If FileExists(GifFile) Then DeleteFile(GifFile);
Gif.SaveToFile(GifFile);
End;
Except
Result := False;
End;
Finally
Bitmap.Free;
Gif .Free;
End;
End;

Function BitmapToGif(Bitmap: TBitmap;Gif: TGifImage): Boolean;
Begin
Try
Gif.Assign(Bitmap);
Result := True;
Except
Result := False;
End;
End;

Function BitmapToGif(BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Var
FileExtOld : String;
FileExtNew : String;
FileNew : String;
FileOld : String;
Begin
FileOld := BitmapFile;
FileExtNew := '.gif';
Result := False;
If Not FileExists(FileOld) Then Exit;
FileExtOld := ExtractFileExt(FileOld);
FileNew := Copy(FileOld,1,Length(FileOld)-Length(FileExtOld))+FileExtNew;
Result := BitmapToGif(FileOld,FileNew);
If DeleteSource Then If Result Then If FileExists(FileOld) Then DeleteFile(FileOld);
End;

Function BitmapToGif(BitmapFile: String): Boolean; Overload;
Begin
Result := BitmapToGif(BitmapFile, True);
End;

Function BitmapToGif(BitmapFile,GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Result := BitmapToGif(BitmapFile,GifFile);
If DeleteSource Then
Begin
If FileExists(BitmapFile) Then DeleteFile(BitmapFile);
Result := Not FileExists(BitmapFile);
End;
End;

Function GifToJpeg(Gif: TGifImage;Jpeg: TJpegImage): Boolean; Overload;
Var
Bitmap : TBitmap;
Begin
Result := False;
If Gif = nil Then Exit;
Try
Bitmap := TBitmap.Create();
Try
Bitmap.Assign(Gif.Bitmap);
Result := BitmapToJPeg(Bitmap,Jpeg);
Finally
Bitmap.Free;
End;
Except
Result := False;
End;
End;

Function GifToJPeg(GifFile,JpegFile: String): Boolean; Overload;
Var
Gif : TGifImage;
Jpeg : TJpegImage;
Begin
Result := False;
If Not FileExists(GifFile) Then Exit;
Gif := TGifImage .Create();
Jpeg := TJpegImage.Create();
Try
Try
Gif.LoadFromFile(GifFile);
Result := GifToJPeg(Gif,Jpeg);
If Result Then
Begin
If FileExists(JpegFile) Then DeleteFile(JpegFile);
Jpeg.SaveToFile(JpegFile);
End;
Except
Result := False;
End;
Finally
Gif .Free;
Jpeg .Free;
End;
End;

Function GifToJPeg(GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Var
FileExtOld : String;
FileExtNew : String;
FileNew : String;
FileOld : String;
Begin
FileOld := GifFile;
FileExtNew := '.jpg';
Result := False;
If Not FileExists(FileOld) Then Exit;
FileExtOld := ExtractFileExt(FileOld);
FileNew := Copy(FileOld,1,Length(FileOld)-Length(FileExtOld))+FileExtNew;
Result := GifToJpeg(FileOld,FileNew);
If DeleteSource Then If Result Then If FileExists(FileOld) Then DeleteFile(FileOld);
End;

Function GifToJPeg(GifFile: String): Boolean; Overload;
Begin
Result := GifToJPeg(GifFile, True);
End;

Function GifToJPeg(GifFile,JpegFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Result := GifToJPeg(GifFile,JpegFile);
If DeleteSource Then
Begin
If FileExists(GifFile) Then DeleteFile(GifFile);
Result := Not FileExists(GifFile);
End;
End;

//******************************************************************************

Function JpegToGif(Jpeg: TJpegImage;Gif: TGifImage): Boolean; Overload;
Var
Bitmap : TBitmap;
Begin
Result := False;
If Jpeg = nil Then Exit;
Try
Bitmap := TBitmap.Create();
Try
Bitmap.Assign(Jpeg);
Result := BitmapToGif(Bitmap,Gif);
Finally
Bitmap.Free;
End;
Except
Result := False;
End;
End;

Function JpegToGif(JpegFile,GifFile: String): Boolean; Overload;
Var
Jpeg : TJpegImage;
Gif : TGifImage;
Begin
Result := False;
If Not FileExists(JpegFile) Then Exit;
Jpeg := TJpegImage .Create();
Gif := TGifImage.Create();
Try
Try
Jpeg.LoadFromFile(JpegFile);
Result := JpegToGif(Jpeg,Gif);
If Result Then
Begin
If FileExists(GifFile) Then DeleteFile(GifFile);
Gif.SaveToFile(GifFile);
End;
Except
Result := False;
End;
Finally
Jpeg .Free;
Gif .Free;
End;
End;

Function JpegToGif(JpegFile: String; DeleteSource: Boolean): Boolean; Overload;
Var
FileExtOld : String;
FileExtNew : String;
FileNew : String;
FileOld : String;
Begin
FileOld := JpegFile;
FileExtNew := '.jpg';
Result := False;
If Not FileExists(FileOld) Then Exit;
FileExtOld := ExtractFileExt(FileOld);
FileNew := Copy(FileOld,1,Length(FileOld)-Length(FileExtOld))+FileExtNew;
Result := JpegToGif(FileOld,FileNew);
If DeleteSource Then If Result Then If FileExists(FileOld) Then DeleteFile(FileOld);
End;

Function JpegToGif(JpegFile: String): Boolean; Overload;
Begin
Result := JpegToGif(JpegFile, True);
End;

Function JpegToGif(JpegFile,GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Result := JpegToGif(JpegFile,GifFile);
If DeleteSource Then
Begin
If FileExists(JpegFile) Then DeleteFile(JpegFile);
Result := Not FileExists(JpegFile);
End;
End;

Function BitmapToTiff(Bitmap: TBitmap;TiffFile: String): Boolean; Overload;
Var
Stream : TFileStream;
Begin
Result := False;
If Bitmap = nil Then Exit;
If Bitmap.Handle = 0 Then Exit;
Try
Stream := TFileStream.Create(TiffFile,fmCreate);
Try
If FileExists(TiffFile) Then DeleteFile(TiffFile);
Result := BitmapToTiff(Bitmap,Stream);
Finally
Stream.Free;
End;
Except
Result := False;
End;
End;

Function BitmapToTiff(BitmapFile,TiffFile: String): Boolean; Overload;
Var
Bitmap : TBitmap;
Begin
Result := False;
If Not FileExists(BitmapFile) Then Exit;
Try
Bitmap := TBitmap.Create();
Try
Bitmap.LoadFromFile(BitmapFile);
Result := BitmapToTiff(Bitmap,TiffFile);
Finally
Bitmap.Free;
End;
Except
Result := False;
End;
End;

Function BitmapToTiff(BitmapFile,TiffFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Try
Result := BitmapToTiff(BitmapFile,TiffFile);
If Result Then If DeleteSource Then DeleteFile(BitmapFile);
Except
Result := False;
End;
End;

Function BitmapToTiff(BitmapFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Try
Result := BitmapToTiff(BitmapFile,ChangeFileExt(BitmapFile,'.tif'));
If Result Then If DeleteSource Then DeleteFile(BitmapFile);
Except
Result := False;
End;
End;

Function BitmapToTiff(BitmapFile: String): Boolean; Overload;
Begin
Try
Result := BitmapToTiff(BitmapFile,True);
Except
Result := False;
End;
End;

//***START TIFF ROUTINES BY Wolfgang Krug ****************************************

type
PDirEntry = ^TDirEntry;
TDirEntry = record
_Tag : Word;
_Type : Word;
_Count : LongInt;
_Value : LongInt;
end;

{$IFDEF WINDOWS}
CONST
{$ELSE}
VAR
{$ENDIF}
{ TIFF File Header: }
TifHeader : array[0..7] of Byte = (
$49, $49, { Intel byte order }
$2a, $00, { TIFF version (42) }
$08, $00, $00, $00 ); { Pointer to the first directory }

NoOfDirs : array[0..1] of Byte = ( $0F, $00 ); { Number of tags within the directory }

DirectoryBW : array[0..13] of TDirEntry = (
( _Tag: $00FE; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { NewSubFile: Image with full solution (0) }
( _Tag: $0100; _Type: $0003; _Count: $00000001; _Value: $00000000 ), { ImageWidth: Value will be set later }
( _Tag: $0101; _Type: $0003; _Count: $00000001; _Value: $00000000 ), { ImageLength: Value will be set later }
( _Tag: $0102; _Type: $0003; _Count: $00000001; _Value: $00000001 ), { BitsPerSample: 1 }
( _Tag: $0103; _Type: $0003; _Count: $00000001; _Value: $00000001 ), { Compression: No compression }
( _Tag: $0106; _Type: $0003; _Count: $00000001; _Value: $00000001 ), { PhotometricInterpretation: 0, 1 }
( _Tag: $0111; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { StripOffsets: Ptr to the adress of the image data }
( _Tag: $0115; _Type: $0003; _Count: $00000001; _Value: $00000001 ), { SamplesPerPixels: 1 }
( _Tag: $0116; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { RowsPerStrip: Value will be set later }
( _Tag: $0117; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { StripByteCounts: xs*ys bytes pro strip }
( _Tag: $011A; _Type: $0005; _Count: $00000001; _Value: $00000000 ), { X-Resolution: Adresse }
( _Tag: $011B; _Type: $0005; _Count: $00000001; _Value: $00000000 ), { Y-Resolution: (Adresse) }
( _Tag: $0128; _Type: $0003; _Count: $00000001; _Value: $00000002 ), { Resolution Unit: (2)= Unit ZOLL }
( _Tag: $0131; _Type: $0002; _Count: $0000000A; _Value: $00000000 )); { Software: }

DirectoryCOL : array[0..14] of TDirEntry = (
( _Tag: $00FE; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { NewSubFile: Image with full solution (0) }
( _Tag: $0100; _Type: $0003; _Count: $00000001; _Value: $00000000 ), { ImageWidth: Value will be set later }
( _Tag: $0101; _Type: $0003; _Count: $00000001; _Value: $00000000 ), { ImageLength: Value will be set later }
( _Tag: $0102; _Type: $0003; _Count: $00000001; _Value: $00000008 ), { BitsPerSample: 4 or 8 }
( _Tag: $0103; _Type: $0003; _Count: $00000001; _Value: $00000001 ), { Compression: No compression }
( _Tag: $0106; _Type: $0003; _Count: $00000001; _Value: $00000003 ), { PhotometricInterpretation: 3 }
( _Tag: $0111; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { StripOffsets: Ptr to the adress of the image data }
( _Tag: $0115; _Type: $0003; _Count: $00000001; _Value: $00000001 ), { SamplesPerPixels: 1 }
( _Tag: $0116; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { RowsPerStrip: Value will be set later }
( _Tag: $0117; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { StripByteCounts: xs*ys bytes pro strip }
( _Tag: $011A; _Type: $0005; _Count: $00000001; _Value: $00000000 ), { X-Resolution: Adresse }
( _Tag: $011B; _Type: $0005; _Count: $00000001; _Value: $00000000 ), { Y-Resolution: (Adresse) }
( _Tag: $0128; _Type: $0003; _Count: $00000001; _Value: $00000002 ), { Resolution Unit: (2)= Unit ZOLL }
( _Tag: $0131; _Type: $0002; _Count: $0000000A; _Value: $00000000 ), { Software: }
( _Tag: $0140; _Type: $0003; _Count: $00000300; _Value: $00000008 ) );{ ColorMap: Color table startadress }

DirectoryRGB : array[0..14] of TDirEntry = (
( _Tag: $00FE; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { NewSubFile: Image with full solution (0) }
( _Tag: $0100; _Type: $0003; _Count: $00000001; _Value: $00000000 ), { ImageWidth: Value will be set later }
( _Tag: $0101; _Type: $0003; _Count: $00000001; _Value: $00000000 ), { ImageLength: Value will be set later }
( _Tag: $0102; _Type: $0003; _Count: $00000003; _Value: $00000008 ), { BitsPerSample: 8 }
( _Tag: $0103; _Type: $0003; _Count: $00000001; _Value: $00000001 ), { Compression: No compression }
( _Tag: $0106; _Type: $0003; _Count: $00000001; _Value: $00000002 ), { PhotometricInterpretation:
0=black, 2 power BitsPerSample -1 =white }
( _Tag: $0111; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { StripOffsets: Ptr to the adress of the image data }
( _Tag: $0115; _Type: $0003; _Count: $00000001; _Value: $00000003 ), { SamplesPerPixels: 3 }
( _Tag: $0116; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { RowsPerStrip: Value will be set later }
( _Tag: $0117; _Type: $0004; _Count: $00000001; _Value: $00000000 ), { StripByteCounts: xs*ys bytes pro strip }
( _Tag: $011A; _Type: $0005; _Count: $00000001; _Value: $00000000 ), { X-Resolution: Adresse }
( _Tag: $011B; _Type: $0005; _Count: $00000001; _Value: $00000000 ), { Y-Resolution: (Adresse) }
( _Tag: $011C; _Type: $0003; _Count: $00000001; _Value: $00000001 ), { PlanarConfiguration:
Pixel data will be stored continous }
( _Tag: $0128; _Type: $0003; _Count: $00000001; _Value: $00000002 ), { Resolution Unit: (2)= Unit ZOLL }
( _Tag: $0131; _Type: $0002; _Count: $0000000A; _Value: $00000000 )); { Software: }

NullString : array[0..3] of Byte = ( $00, $00, $00, $00 );
X_Res_Value : array[0..7] of Byte = ( $6D,$03,$00,$00, $0A,$00,$00,$00 ); { Value for X-Resolution:
87,7 Pixel/Zoll (SONY SCREEN) }
Y_Res_Value : array[0..7] of Byte = ( $6D,$03,$00,$00, $0A,$00,$00,$00 ); { Value for Y-Resolution: 87,7 Pixel/Zoll }
Software : array[0..9] of Char = ( 'K', 'r', 'u', 'w', 'o', ' ', 's', 'o', 'f', 't');
BitsPerSample : array[0..2] of Word = ( $0008, $0008, $0008 );

Function BitmapToTiff(Bitmap: TBitmap;Stream: TStream): Boolean; Overload;
//Function WriteTiffToStream ( Stream : TStream; Bitmap : TBitmap ): Boolean;
var
BM : HBitmap;
Header, Bits : PChar;
BitsPtr : PChar;
TmpBitsPtr : PChar;
HeaderSize : {$IFDEF WINDOWS} INTEGER {$ELSE} DWORD {$ENDIF} ;
BitsSize : {$IFDEF WINDOWS} LongInt {$ELSE} DWORD {$ENDIF} ;
Width, Height: {$IFDEF WINDOWS} LongInt {$ELSE} Integer {$ENDIF} ;
DataWidth : {$IFDEF WINDOWS} LongInt {$ELSE} Integer {$ENDIF} ;
BitCount : {$IFDEF WINDOWS} LongInt {$ELSE} Integer {$ENDIF} ;
ColorMapRed : array[0..255,0..1] of Byte;
ColorMapGreen: array[0..255,0..1] of Byte;
ColorMapBlue : array[0..255,0..1] of Byte;
ColTabSize : Integer;
I, K : {$IFDEF WINDOWS} LongInt {$ELSE} Integer {$ENDIF} ;
Red, Blue : Char;
{$IFDEF WINDOWS}
RGBArr : Packed Array[0..2] OF CHAR ;
{$ENDIF}
BmpWidth : {$IFDEF WINDOWS} LongInt {$ELSE} Integer {$ENDIF} ;
OffsetXRes : LongInt;
OffsetYRes : LongInt;
OffsetSoftware : LongInt;
OffsetStrip : LongInt;
OffsetDir : LongInt;
OffsetBitsPerSample : LongInt;
{$IFDEF WINDOWS}
MemHandle : THandle ;
MemStream : TMemoryStream ;
ActPos, TmpPos : LongInt;
{$ENDIF}
Begin
Result := False;
Try
BM := Bitmap.Handle;
if BM = 0 then exit;
Result := True;
GetDIBSizes(BM, HeaderSize, BitsSize);
{$IFDEF WINDOWS}
MemHandle := GlobalAlloc ( HeapAllocFlags, HeaderSize + BitsSize ) ;
Header := GlobalLock ( MemHandle ) ;
MemStream := TMemoryStream.Create ;
{$ELSE}
GetMem (Header, HeaderSize + BitsSize);
{$ENDIF}
try
Bits := Header + HeaderSize;
if GetDIB(BM, Bitmap.Palette, Header^, Bits^) then
begin
{ Read Image description }
Width := PBITMAPINFO(Header)^.bmiHeader.biWidth;
Height := PBITMAPINFO(Header)^.bmiHeader.biHeight;
BitCount := PBITMAPINFO(Header)^.bmiHeader.biBitCount;

{$IFDEF WINDOWS}
{ Read Bits into MemoryStream for 16 - Bit - Version }
MemStream.Write ( Bits^, BitsSize ) ;
{$ENDIF}

{ Count max No of Colors }
ColTabSize := (1 shl BitCount);
BmpWidth := Trunc(BitsSize / Height);

{ ========================================================================== }
{ 1 Bit - Bilevel-Image }
{ ========================================================================== }
if BitCount = 1 then // Monochrome Images
begin
DataWidth := ((Width+7) div 8);

DirectoryBW[1]._Value := LongInt(Width); { Image Width }
DirectoryBW[2]._Value := LongInt(abs(Height)); { Image Height }
DirectoryBW[8]._Value := LongInt(abs(Height)); { Rows per Strip }
DirectoryBW[9]._Value := LongInt(DataWidth * abs(Height) ); { Strip Byte Counts }

{ Write TIFF - File for Bilevel-Image }
{-------------------------------------}
{ Write Header }
Stream.Write ( TifHeader,sizeof(TifHeader) );

OffsetStrip := Stream.Position ;
{ Write Image Data }

if Height < bitcount =" 4" bitcount =" 4" bitcount =" 24" bitcount =" 32" bitcount =" 32" gif =" nil" gif =" nil" jpeg =" nil" jpeg =" nil">