unit ads_GraphicConversion; {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 < 0 then
begin
for I:=0 to Height-1 do
begin
{$IFNDEF WINDOWS}
BitsPtr := Bits + I*BmpWidth;
Stream.Write ( BitsPtr^, DataWidth);
{$ELSE}
MemStream.Position := I*BmpWidth;
Stream.CopyFrom ( MemStream, DataWidth ) ;
{$ENDIF}
end;
end
else
begin
{ Flip Image }
for I:=1 to Height do
begin
{$IFNDEF WINDOWS}
BitsPtr := Bits + (Height-I)*BmpWidth;
Stream.Write ( BitsPtr^, DataWidth);
{$ELSE}
MemStream.Position := (Height-I)*BmpWidth;
Stream.CopyFrom ( MemStream, DataWidth ) ;
{$ENDIF}
end;
end;
OffsetXRes := Stream.Position ;
Stream.Write ( X_Res_Value, sizeof(X_Res_Value));
OffsetYRes := Stream.Position ;
Stream.Write ( Y_Res_Value, sizeof(Y_Res_Value));
OffsetSoftware := Stream.Position ;
Stream.Write ( Software, sizeof(Software));
{ Set Adresses into Directory }
DirectoryBW[ 6]._Value := OffsetStrip; { StripOffset }
DirectoryBW[10]._Value := OffsetXRes; { X-Resolution }
DirectoryBW[11]._Value := OffsetYRes; { Y-Resolution }
DirectoryBW[13]._Value := OffsetSoftware; { Software }
{ Write Directory }
OffsetDir := Stream.Position ;
Stream.Write ( NoOfDirs, sizeof(NoOfDirs));
Stream.Write ( DirectoryBW, sizeof(DirectoryBW));
Stream.Write ( NullString, sizeof(NullString));
{ Update Start of Directory }
Stream.Seek ( 4, soFromBeginning ) ;
Stream.Write ( OffsetDir, sizeof(OffsetDir));
end;
{ ========================================================================== }
{ 4, 8, 16 Bit - Image with Color Table }
{ ========================================================================== }
if BitCount in [4, 8, 16] then
begin
DataWidth := Width;
if BitCount = 4 then
begin
{ If we have only 4 bit per pixel, we have to
truncate the size of the image to a byte boundary }
Width := (Width div BitCount) * BitCount;
if BitCount = 4 then DataWidth := Width div 2;
end;
DirectoryCOL[1]._Value := LongInt(Width); { Image Width }
DirectoryCOL[2]._Value := LongInt(abs(Height)); { Image Height }
DirectoryCOL[3]._Value := LongInt(BitCount); { BitsPerSample }
DirectoryCOL[8]._Value := LongInt(Height); { Image Height }
DirectoryCOL[9]._Value := LongInt(DataWidth * abs(Height) ); { Strip Byte Counts }
for I:=0 to ColTabSize-1 do
begin
ColorMapRed [I][1] := PBITMAPINFO(Header)^.bmiColors[I].rgbRed;
ColorMapRed [I][0] := 0;
ColorMapGreen[I][1] := PBITMAPINFO(Header)^.bmiColors[I].rgbGreen;
ColorMapGreen[I][0] := 0;
ColorMapBlue [I][1] := PBITMAPINFO(Header)^.bmiColors[I].rgbBlue;
ColorMapBlue [I][0] := 0;
end;
DirectoryCOL[14]._Count := LongInt(ColTabSize*3);
{ Write TIFF - File for Image with Color Table }
{----------------------------------------------}
{ Write Header }
Stream.Write ( TifHeader,sizeof(TifHeader) );
Stream.Write ( ColorMapRed, ColTabSize*2 );
Stream.Write ( ColorMapGreen, ColTabSize*2 );
Stream.Write ( ColorMapBlue, ColTabSize*2 );
OffsetXRes := Stream.Position ;
Stream.Write ( X_Res_Value, sizeof(X_Res_Value));
OffsetYRes := Stream.Position ;
Stream.Write ( Y_Res_Value, sizeof(Y_Res_Value));
OffsetSoftware := Stream.Position ;
Stream.Write ( Software, sizeof(Software));
OffsetStrip := Stream.Position ;
{ Write Image Data }
if Height < 0 then
begin
for I:=0 to Height-1 do
begin
{$IFNDEF WINDOWS}
BitsPtr := Bits + I*BmpWidth;
Stream.Write ( BitsPtr^, DataWidth);
{$ELSE}
MemStream.Position := I*BmpWidth;
Stream.CopyFrom ( MemStream, DataWidth ) ;
{$ENDIF}
end;
end
else
begin
{ Flip Image }
for I:=1 to Height do
begin
{$IFNDEF WINDOWS}
BitsPtr := Bits + (Height-I)*BmpWidth;
Stream.Write ( BitsPtr^, DataWidth);
{$ELSE}
MemStream.Position := (Height-I)*BmpWidth;
Stream.CopyFrom ( MemStream, DataWidth ) ;
{$ENDIF}
end;
end;
{ Set Adresses into Directory }
DirectoryCOL[ 6]._Value := OffsetStrip; { StripOffset }
DirectoryCOL[10]._Value := OffsetXRes; { X-Resolution }
DirectoryCOL[11]._Value := OffsetYRes; { Y-Resolution }
DirectoryCOL[13]._Value := OffsetSoftware; { Software }
{ Write Directory }
OffsetDir := Stream.Position ;
Stream.Write ( NoOfDirs, sizeof(NoOfDirs));
Stream.Write ( DirectoryCOL, sizeof(DirectoryCOL));
Stream.Write ( NullString, sizeof(NullString));
{ Update Start of Directory }
Stream.Seek ( 4, soFromBeginning ) ;
Stream.Write ( OffsetDir, sizeof(OffsetDir));
end;
if BitCount in [24, 32] then
begin
{ ========================================================================== }
{ 24, 32 - Bit - Image with with RGB-Values }
{ ========================================================================== }
DirectoryRGB[1]._Value := LongInt(Width); { Image Width }
DirectoryRGB[2]._Value := LongInt(Height); { Image Height }
DirectoryRGB[8]._Value := LongInt(Height); { Image Height }
DirectoryRGB[9]._Value := LongInt(3*Width*Height); { Strip Byte Counts }
{ Write TIFF - File for Image with RGB-Values }
{ ------------------------------------------- }
{ Write Header }
Stream.Write ( TifHeader, sizeof(TifHeader));
OffsetXRes := Stream.Position ;
Stream.Write ( X_Res_Value, sizeof(X_Res_Value));
OffsetYRes := Stream.Position ;
Stream.Write ( Y_Res_Value, sizeof(Y_Res_Value));
OffsetBitsPerSample := Stream.Position ;
Stream.Write ( BitsPerSample, sizeof(BitsPerSample));
OffsetSoftware := Stream.Position ;
Stream.Write ( Software, sizeof(Software));
OffsetStrip := Stream.Position ;
{ Exchange Red and Blue Color-Bits }
for I:=0 to Height-1 do
begin
{$IFNDEF WINDOWS}
BitsPtr := Bits + I*BmpWidth;
{$ELSE}
MemStream.Position := I*BmpWidth ;
{$ENDIF}
for K:=0 to Width-1 do
begin
{$IFNDEF WINDOWS}
Blue := (BitsPtr)^ ;
Red := (BitsPtr+2)^;
(BitsPtr)^ := Red;
(BitsPtr+2)^ := Blue;
if BitCount = 24
then BitsPtr := BitsPtr + 3 // 24 - Bit Images
else BitsPtr := BitsPtr + 4; // 32 - Bit images
{$ELSE}
MemStream.Read ( RGBArr, SizeOf(RGBArr) ) ;
MemStream.Seek ( -SizeOf(RGBArr), soFromCurrent ) ;
Blue := RGBArr[0];
Red := RGBArr[2];
RGBArr[0] := Red;
RGBArr[2] := Blue;
MemStream.Write ( RGBArr, SizeOf(RGBArr) ) ;
if BitCount = 32 then
MemStream.Seek ( 1, soFromCurrent ) ;
{$ENDIF}
end;
end;
// If we have 32-Bit Image: skip every 4-th pixel
if BitCount = 32 then
begin
for I:=0 to Height-1 do
begin
{$IFNDEF WINDOWS}
BitsPtr := Bits + I*BmpWidth;
TmpBitsPtr := BitsPtr;
{$ELSE}
MemStream.Position := I*BmpWidth ;
ActPos := MemStream.Position;
TmpPos := ActPos;
{$ENDIF}
for k:=0 to Width-1 do
begin
{$IFNDEF WINDOWS}
(TmpBitsPtr)^ := (BitsPtr)^;
(TmpBitsPtr+1)^ := (BitsPtr+1)^;
(TmpBitsPtr+2)^ := (BitsPtr+2)^;
TmpBitsPtr := TmpBitsPtr + 3;
BitsPtr := BitsPtr + 4;
{$ELSE}
MemStream.Seek ( ActPos, soFromBeginning ) ;
MemStream.Read ( RGBArr, SizeOf(RGBArr) ) ;
MemStream.Seek ( TmpPos, soFromBeginning ) ;
MemStream.Write( RGBArr, SizeOf(RGBArr) ) ;
TmpPos := TmpPos + 3;
ActPos := ActPos + 4;
{$ENDIF}
end;
end;
end;
{ Write Image Data }
if Height < 0 then
begin
BmpWidth := Trunc(BitsSize / Height);
for I:=0 to Height-1 do
begin
{$IFNDEF WINDOWS}
BitsPtr := Bits + I*BmpWidth;
Stream.Write ( BitsPtr^, Width*3 ) ;
{$ELSE}
MemStream.Position := I*BmpWidth ;
Stream.CopyFrom ( MemStream, Width*3 ) ;
{$ENDIF}
end;
end
else
begin
{ Write Image Data and Flip Image horizontally }
BmpWidth := Trunc(BitsSize / Height);
for I:=1 to Height do
begin
{$IFNDEF WINDOWS}
BitsPtr := Bits + (Height-I)*BmpWidth;
Stream.Write ( BitsPtr^, Width*3 );
{$ELSE}
MemStream.Position := (Height-I)*BmpWidth;
Stream.CopyFrom ( MemStream, Width*3 ) ;
{$ENDIF}
end;
end;
{ Set Offset - Adresses into Directory }
DirectoryRGB[ 3]._Value := OffsetBitsPerSample; { BitsPerSample }
DirectoryRGB[ 6]._Value := OffsetStrip; { StripOffset }
DirectoryRGB[10]._Value := OffsetXRes; { X-Resolution }
DirectoryRGB[11]._Value := OffsetYRes; { Y-Resolution }
DirectoryRGB[14]._Value := OffsetSoftware; { Software }
{ Write Directory }
OffsetDir := Stream.Position ;
Stream.Write ( NoOfDirs, sizeof(NoOfDirs));
Stream.Write ( DirectoryRGB, sizeof(DirectoryRGB));
Stream.Write ( NullString, sizeof(NullString));
{ Update Start of Directory }
Stream.Seek ( 4, soFromBeginning ) ;
Stream.Write ( OffsetDir, sizeof(OffsetDir));
end;
end;
finally
{$IFDEF WINDOWS}
GlobalUnlock ( MemHandle ) ;
GlobalFree ( MemHandle ) ;
MemStream.Free ;
{$ELSE}
FreeMem(Header);
{$ENDIF}
end;
Except
Result := False;
End;
end;
//***END TIFF ROUTINES BY Wolfgang Krug ****************************************
Function GifToTiff(Gif: TGifImage;Stream: TStream): Boolean; Overload;
Var
Bitmap : TBitmap;
Begin
Result := False;
If Gif = nil Then Exit;
Try
Bitmap := TBitmap.Create();
Try
Result := GifToBitmap(Gif,Bitmap);
If Result Then Result := BitmapToTiff(Bitmap,Stream);
Finally
Bitmap.Free;
End;
Except
Result := False;
End;
End;
Function GifToTiff(Gif: TGifImage;TiffFile: String): Boolean; Overload;
Var
Stream : TFileStream;
Begin
Result := False;
If Gif = nil Then Exit;
Try
Stream := TFileStream.Create(TiffFile,fmCreate);
Try
If FileExists(TiffFile) Then DeleteFile(TiffFile);
Result := GifToTiff(Gif,Stream);
Finally
Stream.Free;
End;
Except
Result := False;
End;
End;
Function GifToTiff(GifFile,TiffFile: String): Boolean; Overload;
Var
Gif : TGifImage;
Begin
Result := False;
If Not FileExists(GifFile) Then Exit;
Try
Gif := TGifImage.Create();
Try
Gif.LoadFromFile(GifFile);
Result := GifToTiff(Gif,TiffFile);
Finally
Gif.Free;
End;
Except
Result := False;
End;
End;
Function GifToTiff(GifFile,TiffFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Try
Result := GifToTiff(GifFile,TiffFile);
If Result Then If DeleteSource Then DeleteFile(GifFile);
Except
Result := False;
End;
End;
Function GifToTiff(GifFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Try
Result := GifToTiff(GifFile,ChangeFileExt(GifFile,'.tif'));
If Result Then If DeleteSource Then DeleteFile(GifFile);
Except
Result := False;
End;
End;
Function GifToTiff(GifFile: String): Boolean; Overload;
Begin
Try
Result := GifToTiff(GifFile,True);
Except
Result := False;
End;
End;
//*****************************************************************************
Function JpegToTiff(Jpeg: TJpegImage;Stream: TStream): Boolean; Overload;
Var
Bitmap : TBitmap;
Begin
Result := False;
If Jpeg = nil Then Exit;
Try
Bitmap := TBitmap.Create();
Try
Result := JpegToBitmap(Jpeg,Bitmap);
If Result Then Result := BitmapToTiff(Bitmap,Stream);
Finally
Bitmap.Free;
End;
Except
Result := False;
End;
End;
Function JpegToTiff(Jpeg: TJpegImage;TiffFile: String): Boolean; Overload;
Var
Stream : TFileStream;
Begin
Result := False;
If Jpeg = nil Then Exit;
Try
Stream := TFileStream.Create(TiffFile,fmCreate);
Try
If FileExists(TiffFile) Then DeleteFile(TiffFile);
Result := JpegToTiff(Jpeg,Stream);
Finally
Stream.Free;
End;
Except
Result := False;
End;
End;
Function JpegToTiff(JpegFile,TiffFile: String): Boolean; Overload;
Var
Jpeg : TJpegImage;
Begin
Result := False;
If Not FileExists(JpegFile) Then Exit;
Try
Jpeg := TJpegImage.Create();
Try
Jpeg.LoadFromFile(JpegFile);
Result := JpegToTiff(Jpeg,TiffFile);
Finally
Jpeg.Free;
End;
Except
Result := False;
End;
End;
Function JpegToTiff(JpegFile,TiffFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Try
Result := JpegToTiff(JpegFile,TiffFile);
If Result Then If DeleteSource Then DeleteFile(JpegFile);
Except
Result := False;
End;
End;
Function JpegToTiff(JpegFile: String; DeleteSource: Boolean): Boolean; Overload;
Begin
Try
Result := JpegToTiff(JpegFile,ChangeFileExt(JpegFile,'.tif'));
If Result Then If DeleteSource Then DeleteFile(JpegFile);
Except
Result := False;
End;
End;
Function JpegToTiff(JpegFile: String): Boolean; Overload;
Begin
Try
Result := JpegToTiff(JpegFile,True);
Except
Result := False;
End;
End;
end.
//