mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 12:59:29 +01:00
691 lines
19 KiB
ObjectPascal
691 lines
19 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2008 by the Free Pascal development team
|
|
|
|
Tiff reader for fpImage.
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************
|
|
|
|
Working:
|
|
Grayscale 8,16bit (optional alpha),
|
|
RGB 8,16bit (optional alpha),
|
|
Orientation,
|
|
|
|
ToDo:
|
|
Compression: LZW, packbits, deflate, jpeg, ...
|
|
thumbnail
|
|
Planar
|
|
ColorMap
|
|
multiple images
|
|
separate mask
|
|
pages
|
|
fillorder - not needed by baseline tiff reader
|
|
bigtiff 64bit offsets
|
|
endian - currently using system endianess
|
|
}
|
|
unit FPWriteTiff;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
{off $DEFINE VerboseTiffWriter}
|
|
|
|
interface
|
|
|
|
uses
|
|
Math, Classes, SysUtils, FPimage, FPTiffCmn;
|
|
|
|
type
|
|
|
|
{ TTiffWriteEntry }
|
|
|
|
TTiffWriteEntry = class
|
|
public
|
|
Tag: Word;
|
|
EntryType: Word;
|
|
Count: DWord;
|
|
Data: Pointer;
|
|
DataPos: DWord;
|
|
Bytes: DWord;
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TTiffWriteStrip = record
|
|
Data: Pointer;
|
|
Bytes: DWord;
|
|
end;
|
|
PTiffWriteStrip = ^TTiffWriteStrip;
|
|
|
|
{ TTiffWriteStripOffsets }
|
|
|
|
TTiffWriteStripOffsets = class(TTiffWriteEntry)
|
|
public
|
|
Strips: PTiffWriteStrip;
|
|
StripByteCounts: TTiffWriteEntry;
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure SetCount(NewCount: DWord);
|
|
end;
|
|
|
|
{ TFPWriterTiff }
|
|
|
|
TFPWriterTiff = class(TFPCustomImageWriter)
|
|
private
|
|
FSaveCMYKAsRGB: boolean;
|
|
fStartPos: Int64;
|
|
FEntries: TFPList; // list of TFPList of TTiffWriteEntry
|
|
fStream: TStream;
|
|
fPosition: DWord;
|
|
procedure ClearEntries;
|
|
procedure WriteTiff;
|
|
procedure WriteHeader;
|
|
procedure WriteIDFs;
|
|
procedure WriteEntry(Entry: TTiffWriteEntry);
|
|
procedure WriteData;
|
|
procedure WriteEntryData(Entry: TTiffWriteEntry);
|
|
procedure WriteBuf(var Buf; Count: DWord);
|
|
procedure WriteWord(w: Word);
|
|
procedure WriteDWord(d: DWord);
|
|
protected
|
|
procedure InternalWrite(Stream: TStream; Img: TFPCustomImage); override;
|
|
procedure AddEntryString(Tag: word; const s: string);
|
|
procedure AddEntryShort(Tag: word; Value: Word);
|
|
procedure AddEntryLong(Tag: word; Value: DWord);
|
|
procedure AddEntryRational(Tag: word; const Value: TTiffRational);
|
|
procedure AddEntry(Tag: Word; EntryType: Word; EntryCount: DWord;
|
|
Data: Pointer; Bytes: DWord;
|
|
CopyData: boolean = true);
|
|
procedure AddEntry(Entry: TTiffWriteEntry);
|
|
procedure TiffError(Msg: string);
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
procedure AddImage(Img: TFPCustomImage);
|
|
procedure SaveToStream(Stream: TStream);
|
|
property SaveCMYKAsRGB: boolean read FSaveCMYKAsRGB write FSaveCMYKAsRGB;
|
|
end;
|
|
|
|
function CompareTiffWriteEntries(Entry1, Entry2: Pointer): integer;
|
|
|
|
implementation
|
|
|
|
function CompareTiffWriteEntries(Entry1, Entry2: Pointer): integer;
|
|
begin
|
|
Result:=integer(TTiffWriteEntry(Entry1).Tag)-integer(TTiffWriteEntry(Entry2).Tag);
|
|
end;
|
|
|
|
{ TFPWriterTiff }
|
|
|
|
procedure TFPWriterTiff.WriteWord(w: Word);
|
|
begin
|
|
if fStream<>nil then
|
|
fStream.WriteWord(w);
|
|
inc(fPosition,2);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.WriteDWord(d: DWord);
|
|
begin
|
|
if fStream<>nil then
|
|
fStream.WriteDWord(d);
|
|
inc(fPosition,4);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.ClearEntries;
|
|
var
|
|
i: Integer;
|
|
List: TFPList;
|
|
j: Integer;
|
|
begin
|
|
for i:=FEntries.Count-1 downto 0 do begin
|
|
List:=TFPList(FEntries[i]);
|
|
for j:=List.Count-1 downto 0 do
|
|
TObject(List[j]).Free;
|
|
List.Free;
|
|
end;
|
|
FEntries.Clear;
|
|
end;
|
|
|
|
procedure TFPWriterTiff.WriteTiff;
|
|
begin
|
|
{$IFDEF VerboseTiffWriter}
|
|
writeln('TFPWriterTiff.WriteTiff fStream=',fStream<>nil);
|
|
{$ENDIF}
|
|
fPosition:=0;
|
|
WriteHeader;
|
|
WriteIDFs;
|
|
WriteData;
|
|
end;
|
|
|
|
procedure TFPWriterTiff.WriteHeader;
|
|
var
|
|
EndianMark: String;
|
|
begin
|
|
EndianMark:={$IFDEF FPC_BIG_ENDIAN}'MM'{$ELSE}'II'{$ENDIF};
|
|
WriteBuf(EndianMark[1],2);
|
|
WriteWord(42);
|
|
WriteDWord(8);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.WriteIDFs;
|
|
var
|
|
i: Integer;
|
|
List: TFPList;
|
|
j: Integer;
|
|
Entry: TTiffWriteEntry;
|
|
NextIDFPos: DWord;
|
|
begin
|
|
for i:=0 to FEntries.Count-1 do begin
|
|
List:=TFPList(FEntries[i]);
|
|
// write count
|
|
{$IFDEF VerboseTiffWriter}
|
|
writeln('TFPWriterTiff.WriteIDFs Count=',List.Count);
|
|
{$ENDIF}
|
|
WriteWord(List.Count);
|
|
// write array of entries
|
|
for j:=0 to List.Count-1 do begin
|
|
Entry:=TTiffWriteEntry(List[j]);
|
|
WriteEntry(Entry);
|
|
end;
|
|
// write position of next IDF
|
|
if i<FEntries.Count-1 then
|
|
NextIDFPos:=fPosition+4
|
|
else
|
|
NextIDFPos:=0;
|
|
WriteDWord(NextIDFPos);
|
|
end;
|
|
end;
|
|
|
|
procedure TFPWriterTiff.WriteEntry(Entry: TTiffWriteEntry);
|
|
var
|
|
PadBytes: DWord;
|
|
begin
|
|
{$IFDEF VerboseTiffWriter}
|
|
writeln('TFPWriterTiff.WriteEntry Tag=',Entry.Tag,' Type=',Entry.EntryType,' Count=',Entry.Count,' Bytes=',Entry.Bytes);
|
|
{$ENDIF}
|
|
WriteWord(Entry.Tag);
|
|
WriteWord(Entry.EntryType);
|
|
WriteDWord(Entry.Count);
|
|
if Entry.Bytes<=4 then begin
|
|
if Entry.Bytes>0 then
|
|
WriteBuf(Entry.Data^,Entry.Bytes);
|
|
PadBytes:=0;
|
|
WriteBuf(PadBytes,4-Entry.Bytes);
|
|
end else begin
|
|
WriteDWord(Entry.DataPos);
|
|
end;
|
|
end;
|
|
|
|
procedure TFPWriterTiff.WriteData;
|
|
var
|
|
i: Integer;
|
|
List: TFPList;
|
|
j: Integer;
|
|
Entry: TTiffWriteEntry;
|
|
Strips: TTiffWriteStripOffsets;
|
|
k: Integer;
|
|
Bytes: DWord;
|
|
begin
|
|
for i:=0 to FEntries.Count-1 do begin
|
|
List:=TFPList(FEntries[i]);
|
|
// write entry data
|
|
for j:=0 to List.Count-1 do begin
|
|
Entry:=TTiffWriteEntry(List[j]);
|
|
WriteEntryData(Entry);
|
|
end;
|
|
// write strips
|
|
for j:=0 to List.Count-1 do begin
|
|
Entry:=TTiffWriteEntry(List[j]);
|
|
if Entry is TTiffWriteStripOffsets then begin
|
|
Strips:=TTiffWriteStripOffsets(Entry);
|
|
// write Strips
|
|
for k:=0 to Strips.Count-1 do begin
|
|
PDWord(Strips.Data)[k]:=fPosition;
|
|
Bytes:=Strips.Strips[k].Bytes;
|
|
PDWord(Strips.StripByteCounts.Data)[k]:=Bytes;
|
|
{$IFDEF VerboseTiffWriter}
|
|
//writeln('TFPWriterTiff.WriteData Strip fPosition=',fPosition,' Bytes=',Bytes);
|
|
{$ENDIF}
|
|
if Bytes>0 then
|
|
WriteBuf(Strips.Strips[k].Data^,Bytes);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TFPWriterTiff.WriteEntryData(Entry: TTiffWriteEntry);
|
|
begin
|
|
if Entry.Bytes>4 then begin
|
|
Entry.DataPos:=fPosition;
|
|
WriteBuf(Entry.Data^,Entry.Bytes);
|
|
end;
|
|
end;
|
|
|
|
procedure TFPWriterTiff.WriteBuf(var Buf; Count: DWord);
|
|
begin
|
|
if Count=0 then exit;
|
|
if (fStream<>nil) then
|
|
fStream.Write(Buf,Count);
|
|
inc(fPosition,Count);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.AddImage(Img: TFPCustomImage);
|
|
var
|
|
IDF: TTiffIDF;
|
|
GrayBits: Word;
|
|
RedBits: Word;
|
|
GreenBits: Word;
|
|
BlueBits: Word;
|
|
AlphaBits: Word;
|
|
ImgWidth: DWord;
|
|
ImgHeight: DWord;
|
|
Compression: Word;
|
|
BitsPerSample: array[0..3] of Word;
|
|
SamplesPerPixel: Integer;
|
|
BitsPerPixel: DWord;
|
|
i: Integer;
|
|
OrientedWidth: DWord;
|
|
OrientedHeight: DWord;
|
|
y: integer;
|
|
x: Integer;
|
|
StripOffsets: TTiffWriteStripOffsets;
|
|
Row: DWord;
|
|
BytesPerLine: DWord;
|
|
StripBytes: DWord;
|
|
Strip: PByte;
|
|
Run: PByte;
|
|
StripIndex: DWord;
|
|
Col: TFPColor;
|
|
Value: Integer;
|
|
dx: Integer;
|
|
dy: Integer;
|
|
CurEntries: TFPList;
|
|
StripCounts: TTiffWriteEntry;
|
|
begin
|
|
StripOffsets:=nil;
|
|
Strip:=nil;
|
|
IDF:=TTiffIDF.Create;
|
|
try
|
|
// add new list of entries
|
|
CurEntries:=TFPList.Create;
|
|
FEntries.Add(CurEntries);
|
|
|
|
if Img.Extra[TiffPhotoMetric]='' then
|
|
IDF.PhotoMetricInterpretation:=2
|
|
else begin
|
|
IDF.PhotoMetricInterpretation:=StrToInt64Def(Img.Extra[TiffPhotoMetric],High(IDF.PhotoMetricInterpretation));
|
|
if SaveCMYKAsRGB and (IDF.PhotoMetricInterpretation=5) then
|
|
IDF.PhotoMetricInterpretation:=2;
|
|
end;
|
|
if not (IDF.PhotoMetricInterpretation in [0,1,2]) then
|
|
TiffError('PhotoMetricInterpretation="'+Img.Extra[TiffPhotoMetric]+'" not supported');
|
|
IDF.Artist:=Img.Extra[TiffArtist];
|
|
IDF.Copyright:=Img.Extra[TiffCopyright];
|
|
IDF.DocumentName:=Img.Extra[TiffDocumentName];
|
|
IDF.DateAndTime:=Img.Extra[TiffDateTime];
|
|
IDF.ImageDescription:=Img.Extra[TiffImageDescription];
|
|
IDF.Orientation:=StrToIntDef(Img.Extra[TiffOrientation],1);
|
|
if not (IDF.Orientation in [1..8]) then
|
|
IDF.Orientation:=1;
|
|
IDF.ResolutionUnit:=StrToIntDef(Img.Extra[TiffResolutionUnit],2);
|
|
if not (IDF.ResolutionUnit in [1..3]) then
|
|
IDF.ResolutionUnit:=2;
|
|
IDF.XResolution:=StrToTiffRationalDef(Img.Extra[TiffXResolution],TiffRational72);
|
|
IDF.YResolution:=StrToTiffRationalDef(Img.Extra[TiffYResolution],TiffRational72);
|
|
|
|
GrayBits:=StrToIntDef(Img.Extra[TiffGrayBits],8);
|
|
RedBits:=StrToIntDef(Img.Extra[TiffRedBits],8);
|
|
GreenBits:=StrToIntDef(Img.Extra[TiffGreenBits],8);
|
|
BlueBits:=StrToIntDef(Img.Extra[TiffBlueBits],8);
|
|
AlphaBits:=StrToIntDef(Img.Extra[TiffAlphaBits],8);
|
|
ImgWidth:=Img.Width;
|
|
ImgHeight:=Img.Height;
|
|
Compression:=1;
|
|
|
|
if IDF.Orientation in [1..4] then begin
|
|
OrientedWidth:=ImgWidth;
|
|
OrientedHeight:=ImgHeight;
|
|
end else begin
|
|
OrientedWidth:=ImgHeight;
|
|
OrientedHeight:=ImgWidth;
|
|
end;
|
|
|
|
{$IFDEF VerboseTiffWriter}
|
|
writeln('TFPWriterTiff.AddImage PhotoMetricInterpretation=',IDF.PhotoMetricInterpretation);
|
|
writeln('TFPWriterTiff.AddImage ImageWidth=',ImgWidth,' ImageHeight=',ImgHeight);
|
|
writeln('TFPWriterTiff.AddImage Orientation=',IDF.Orientation);
|
|
writeln('TFPWriterTiff.AddImage ResolutionUnit=',IDF.ResolutionUnit);
|
|
writeln('TFPWriterTiff.AddImage XResolution=',TiffRationalToStr(IDF.XResolution));
|
|
writeln('TFPWriterTiff.AddImage YResolution=',TiffRationalToStr(IDF.YResolution));
|
|
writeln('TFPWriterTiff.AddImage GrayBits=',GrayBits,' RedBits=',RedBits,' GreenBits=',GreenBits,' BlueBits=',BlueBits,' AlphaBits=',AlphaBits);
|
|
writeln('TFPWriterTiff.AddImage Compression=',Compression);
|
|
{$ENDIF}
|
|
|
|
// required meta entries
|
|
AddEntryShort(262,IDF.PhotoMetricInterpretation);
|
|
AddEntryLong(256,ImgWidth);
|
|
AddEntryLong(257,ImgHeight);
|
|
AddEntryShort(259,Compression);
|
|
AddEntryShort(274,IDF.Orientation);
|
|
AddEntryShort(296,IDF.ResolutionUnit);
|
|
AddEntryRational(282,IDF.XResolution);
|
|
AddEntryRational(283,IDF.YResolution);
|
|
case IDF.PhotoMetricInterpretation of
|
|
0,1:
|
|
begin
|
|
BitsPerSample[0]:=GrayBits;
|
|
SamplesPerPixel:=1;
|
|
end;
|
|
2:
|
|
begin
|
|
BitsPerSample[0]:=RedBits;
|
|
BitsPerSample[1]:=GreenBits;
|
|
BitsPerSample[2]:=BlueBits;
|
|
SamplesPerPixel:=3;
|
|
end;
|
|
end;
|
|
if AlphaBits>0 then begin
|
|
BitsPerSample[SamplesPerPixel]:=AlphaBits;
|
|
inc(SamplesPerPixel);
|
|
// ExtraSamples
|
|
AddEntryShort(338,2);// 2=unassociated alpha
|
|
end;
|
|
// BitsPerSample (required)
|
|
AddEntry(258,3,SamplesPerPixel,@BitsPerSample[0],SamplesPerPixel*2);
|
|
AddEntryShort(277,SamplesPerPixel);
|
|
|
|
// RowsPerStrip (required)
|
|
BitsPerPixel:=0;
|
|
for i:=0 to SamplesPerPixel-1 do
|
|
inc(BitsPerPixel,BitsPerSample[i]);
|
|
BytesPerLine:=(BitsPerPixel*OrientedWidth+7) div 8;
|
|
if OrientedWidth=0 then
|
|
IDF.RowsPerStrip:=8
|
|
else
|
|
IDF.RowsPerStrip:=8192 div BytesPerLine;
|
|
if IDF.RowsPerStrip<1 then
|
|
IDF.RowsPerStrip:=1;
|
|
{$IFDEF VerboseTiffWriter}
|
|
writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' BytesPerLine=',BytesPerLine,' RowsPerStrip=',IDF.RowsPerStrip);
|
|
{$ENDIF}
|
|
AddEntryLong(278,IDF.RowsPerStrip);
|
|
|
|
// optional entries
|
|
if IDF.Artist<>'' then
|
|
AddEntryString(315,IDF.Artist);
|
|
if IDF.Copyright<>'' then
|
|
AddEntryString(33432,IDF.Copyright);
|
|
if IDF.DocumentName<>'' then
|
|
AddEntryString(269,IDF.DocumentName);
|
|
if IDF.DateAndTime<>'' then
|
|
AddEntryString(306,IDF.DateAndTime);
|
|
if IDF.ImageDescription<>'' then
|
|
AddEntryString(270,IDF.ImageDescription);
|
|
|
|
// StripOffsets: StripOffsets, StripByteCounts
|
|
StripOffsets:=TTiffWriteStripOffsets.Create;
|
|
AddEntry(StripOffsets);
|
|
StripCounts:=TTiffWriteEntry.Create;
|
|
StripCounts.Tag:=279;
|
|
StripCounts.EntryType:=4;
|
|
StripOffsets.StripByteCounts:=StripCounts;
|
|
AddEntry(StripCounts);
|
|
if OrientedHeight>0 then begin
|
|
StripOffsets.SetCount((OrientedHeight+IDF.RowsPerStrip-1) div IDF.RowsPerStrip);
|
|
// compute StripOffsets
|
|
Row:=0;
|
|
StripIndex:=0;
|
|
dx:=0;
|
|
dy:=0;
|
|
for y:=0 to OrientedHeight-1 do begin
|
|
if Row=0 then begin
|
|
// allocate Strip for the next rows
|
|
StripBytes:=Min(IDF.RowsPerStrip,OrientedHeight-y)*BytesPerLine;
|
|
//writeln('TFPWriterTiff.AddImage StripIndex=',StripIndex,' StripBytes=',StripBytes);
|
|
GetMem(Strip,StripBytes);
|
|
FillByte(Strip^,StripBytes,0);
|
|
StripOffsets.Strips[StripIndex].Data:=Strip;
|
|
StripOffsets.Strips[StripIndex].Bytes:=StripBytes;
|
|
inc(StripIndex);
|
|
Run:=Strip;
|
|
end;
|
|
// write line
|
|
for x:=0 to OrientedWidth-1 do begin
|
|
// Orientation
|
|
case IDF.Orientation of
|
|
1: begin dx:=x; dy:=y; end;// 0,0 is left, top
|
|
2: begin dx:=OrientedWidth-x-1; dy:=y; end;// 0,0 is right, top
|
|
3: begin dx:=OrientedWidth-x-1; dy:=OrientedHeight-y-1; end;// 0,0 is right, bottom
|
|
4: begin dx:=x; dy:=OrientedHeight-y; end;// 0,0 is left, bottom
|
|
5: begin dx:=y; dy:=x; end;// 0,0 is top, left (rotated)
|
|
6: begin dx:=OrientedHeight-y-1; dy:=x; end;// 0,0 is top, right (rotated)
|
|
7: begin dx:=OrientedHeight-y-1; dy:=OrientedWidth-x-1; end;// 0,0 is bottom, right (rotated)
|
|
8: begin dx:=y; dy:=OrientedWidth-x-1; end;// 0,0 is bottom, left (rotated)
|
|
end;
|
|
Col:=Img.Colors[dx,dy];
|
|
case IDF.PhotoMetricInterpretation of
|
|
0,1:
|
|
begin
|
|
// grayscale
|
|
Value:=(DWord(Col.red)+Col.green+Col.blue) div 3;
|
|
if IDF.PhotoMetricInterpretation=0 then
|
|
Value:=$ffff-Value;// 0 is white
|
|
if GrayBits=8 then begin
|
|
Run^:=Value shr 8;
|
|
inc(Run);
|
|
end else if GrayBits=16 then begin
|
|
PWord(Run)^:=Value;
|
|
inc(Run,2);
|
|
end;
|
|
if AlphaBits=8 then begin
|
|
Run^:=Col.alpha shr 8;
|
|
inc(Run);
|
|
end else if AlphaBits=16 then begin
|
|
PWord(Run)^:=Col.alpha;
|
|
inc(Run,2);
|
|
end;
|
|
end;
|
|
2:
|
|
begin
|
|
// RGB
|
|
if RedBits=8 then begin
|
|
Run^:=Col.red shr 8;
|
|
inc(Run);
|
|
end else if RedBits=16 then begin
|
|
PWord(Run)^:=Col.red;
|
|
inc(Run,2);
|
|
end;
|
|
if GreenBits=8 then begin
|
|
Run^:=Col.green shr 8;
|
|
inc(Run);
|
|
end else if GreenBits=16 then begin
|
|
PWord(Run)^:=Col.green;
|
|
inc(Run,2);
|
|
end;
|
|
if BlueBits=8 then begin
|
|
Run^:=Col.blue shr 8;
|
|
inc(Run);
|
|
end else if BlueBits=16 then begin
|
|
PWord(Run)^:=Col.blue;
|
|
inc(Run,2);
|
|
end;
|
|
if AlphaBits=8 then begin
|
|
Run^:=Col.alpha shr 8;
|
|
inc(Run);
|
|
end else if AlphaBits=16 then begin
|
|
PWord(Run)^:=Col.alpha;
|
|
inc(Run,2);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
// next row
|
|
inc(Row);
|
|
if (Row=IDF.RowsPerStrip) then
|
|
Row:=0;
|
|
end;
|
|
end;
|
|
|
|
CurEntries.Sort(@CompareTiffWriteEntries);
|
|
finally
|
|
IDF.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TFPWriterTiff.SaveToStream(Stream: TStream);
|
|
begin
|
|
fStartPos:=Stream.Position;
|
|
// simulate write to compute offsets
|
|
fStream:=nil;
|
|
WriteTiff;
|
|
// write to stream
|
|
fStream:=Stream;
|
|
WriteTiff;
|
|
fStream:=nil;
|
|
end;
|
|
|
|
procedure TFPWriterTiff.InternalWrite(Stream: TStream; Img: TFPCustomImage);
|
|
begin
|
|
AddImage(Img);
|
|
SaveToStream(Stream);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.AddEntryString(Tag: word; const s: string);
|
|
begin
|
|
if s<>'' then
|
|
AddEntry(Tag,2,length(s)+1,@s[1],length(s)+1)
|
|
else
|
|
AddEntry(Tag,2,0,nil,0);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.AddEntryShort(Tag: word; Value: Word);
|
|
begin
|
|
AddEntry(Tag,3,1,@Value,2);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.AddEntryLong(Tag: word; Value: DWord);
|
|
begin
|
|
AddEntry(Tag,4,1,@Value,4);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.AddEntryRational(Tag: word; const Value: TTiffRational
|
|
);
|
|
begin
|
|
AddEntry(Tag,5,1,@Value,8);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.AddEntry(Tag: Word; EntryType: Word; EntryCount: DWord;
|
|
Data: Pointer; Bytes: DWord; CopyData: boolean);
|
|
var
|
|
Entry: TTiffWriteEntry;
|
|
begin
|
|
Entry:=TTiffWriteEntry.Create;
|
|
Entry.Tag:=Tag;
|
|
Entry.EntryType:=EntryType;
|
|
Entry.Count:=EntryCount;
|
|
if CopyData then begin
|
|
if Bytes>0 then begin
|
|
GetMem(Entry.Data,Bytes);
|
|
System.Move(Data^,Entry.Data^,Bytes);
|
|
end else begin
|
|
Entry.Data:=nil;
|
|
end;
|
|
end else
|
|
Entry.Data:=Data;
|
|
Entry.Bytes:=Bytes;
|
|
AddEntry(Entry);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.AddEntry(Entry: TTiffWriteEntry);
|
|
var
|
|
List: TFPList;
|
|
begin
|
|
List:=TFPList(FEntries[FEntries.Count-1]);
|
|
List.Add(Entry);
|
|
end;
|
|
|
|
procedure TFPWriterTiff.TiffError(Msg: string);
|
|
begin
|
|
raise Exception.Create('TFPWriterTiff.TiffError: '+Msg);
|
|
end;
|
|
|
|
constructor TFPWriterTiff.Create;
|
|
begin
|
|
inherited Create;
|
|
FEntries:=TFPList.Create;
|
|
FSaveCMYKAsRGB:=true;
|
|
end;
|
|
|
|
destructor TFPWriterTiff.Destroy;
|
|
begin
|
|
Clear;
|
|
FreeAndNil(FEntries);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFPWriterTiff.Clear;
|
|
begin
|
|
ClearEntries;
|
|
end;
|
|
|
|
{ TTiffWriteEntry }
|
|
|
|
destructor TTiffWriteEntry.Destroy;
|
|
begin
|
|
ReAllocMem(Data,0);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TTiffWriteStripOffsets }
|
|
|
|
constructor TTiffWriteStripOffsets.Create;
|
|
begin
|
|
Tag:=273;
|
|
EntryType:=4;
|
|
end;
|
|
|
|
destructor TTiffWriteStripOffsets.Destroy;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if Strips<>nil then begin
|
|
for i:=0 to Count-1 do
|
|
ReAllocMem(Strips[i].Data,0);
|
|
ReAllocMem(Strips,0);
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TTiffWriteStripOffsets.SetCount(NewCount: DWord);
|
|
var
|
|
Size: DWord;
|
|
begin
|
|
{$IFDEF VerboseTiffWriter}
|
|
writeln('TTiffWriteStripOffsets.SetCount OldCount=',Count,' NewCount=',NewCount);
|
|
{$ENDIF}
|
|
Count:=NewCount;
|
|
Size:=Count*SizeOf(TTiffWriteStrip);
|
|
ReAllocMem(Strips,Size);
|
|
if Size>0 then FillByte(Strips^,Size,0);
|
|
Size:=Count*SizeOf(DWord);
|
|
// StripOffsets
|
|
ReAllocMem(Data,Size);
|
|
if Size>0 then FillByte(Data^,Size,0);
|
|
Bytes:=Size;
|
|
// StripByteCounts
|
|
ReAllocMem(StripByteCounts.Data,Size);
|
|
if Size>0 then FillByte(StripByteCounts.Data^,Size,0);
|
|
StripByteCounts.Count:=Count;
|
|
StripByteCounts.Bytes:=Size;
|
|
end;
|
|
|
|
end.
|
|
|