paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
d2d4b72692
lazarus-ccr/components/fpexif/fpEXIF.pas
wp_xxyyzz e03afa62f1 fpexif: Initial commit of units and tests 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6080 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2017-12-02 17:12:00 +00:00

3598 lines
116 KiB
ObjectPascal
Raw Blame History

unit fpeExif;
////////////////////////////////////////////////////////////////////////////////
// unit dEXIF - Copyright 2001-2006, Gerry McGuire
//--------------------------------------------------------------------------
// Program to pull the information out of various types of EXIF digital
// camera files and show it in a reasonably consistent way
//
// This module parses the very complicated exif structures.
//
// Matthias Wandel, Dec 1999 - August 2000 (most of the comments)
//
// Translated to Delphi:
// Gerry McGuire, March - April 2001 - Currently - read only
// May 2001 - add EXIF to jpeg output files
// September 2001 - read TIF files, IPTC data
// June 2003 - First (non-beta) Release
//--------------------------------------------------------------------------
// In addition to the basic information provided by Matthias, the
// following web page contains reference informtion regarding the
// exif standard: http://www.pima.net/standards/iso/tc42/wg18/WG18_POW.htm
// (the documents themselves are PDF).
//--------------------------------------------------------------------------
// 17.05.2002 MS Corrections/additions M. Schwaiger
//--------------------------------------------------------------------------
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
{$I fpExif.inc}
interface
uses
SysUtils, Classes, Math, Variants,
{$IFDEF FPC}
LazUTF8,
{$ELSE}
{$IFNDEF dExifNoJpeg} jpeg, {$ENDIF}
{$ENDIF}
fpeGlobal, fpeUtils, fpeTags, fpeIptc;
const
{
ExifTag = 1; // default tag Types
GpsTag = 2;
ThumbTag = 4;
}
// To be used in Exifobj.IterateFoundTags
GenericEXIF = 0;
CustomEXIF = 1;
// AllEXIF = -1;
GenNone = 0;
GenAll = 255;
GenString = 2;
GenList = 4;
// VLMin = 0;
// VLMax = 1;
type
{ TEndInd }
TEndInd = class
private
FData: ansistring;
public
MotorolaOrder: boolean;
function Get16u(AOffs: integer): word;
function Get32s(AOffs: integer): Longint;
function Get32u(AOffs: integer): Longword;
function Put32s(data: Integer): AnsiString;
procedure WriteInt16(var buff: AnsiString; int,posn: integer);
procedure WriteInt32(var buff: AnsiString; int,posn: longint);
function GetDataBuff: Ansistring;
procedure SetDataBuff(const Value: AnsiString);
property DataBuff: AnsiString read GetDataBuff write SetDataBuff;
end;
{ TImageInfo }
TImageInfo = class(tEndInd)
private
FParent: TObject; // must be cast to TImgData, can't be done here due to unit circular reference
FExifVersion: string;
FITagArray: array of TTagEntry;
FITagCount: integer;
FIThumbArray: array of TTagEntry;
FIThumbCount: integer;
FThumbStart: integer;
FThumbLength: integer;
FThumbType: integer;
FThumbnailBuffer: TBytes;
FThumbnailStartOffset: Integer;
FThumbnailSize: Integer;
FIterator: integer;
FThumbIterator: integer;
// Getter / setter
function GetDateTimeOriginal: TDateTime;
procedure SetDateTimeOriginal(const AValue: TDateTime);
function GetDateTimeDigitized: TDateTime;
procedure SetDateTimeDigitized(const AValue: TDateTime);
function GetDateTimeModified: TDateTime;
procedure SetDateTimeModified(const AValue: TDateTime);
function GetArtist: String;
procedure SetArtist(v: String);
function GetExifComment: String; overload;
procedure SetExifComment(AValue: String);
function GetUserComment(const ATag: TTagEntry): String; overload;
function GetImageDescription: String;
procedure SetImageDescription(const AValue: String);
function GetCameraMake: String;
procedure SetCameraMake(const AValue: String);
function GetCameraModel: String;
procedure SetCameraModel(const AValue: String);
function GetCopyright: String;
procedure SetCopyright(const AValue: String);
function GetGPSCoordinate(ATagName: String;
ACoordType: TGpsCoordType): Extended;
procedure SetGPSCoordinate(ATagName: String; const AValue: Extended;
ACoordType: TGpsCoordType);
function GetGPSLatitude: Extended;
procedure SetGPSLatitude(const AValue: Extended);
function GetGPSLongitude: Extended;
procedure SetGPSLongitude(const AValue: Extended);
function GetHeight: Integer;
procedure Setheight(AValue: Integer);
function GetWidth: Integer;
procedure SetWidth(AValue: Integer);
function GetVersion(ATag: TTagEntry): String;
function GetTagByID(ATagID: Word): TTagEntry;
procedure SetTagByID(ATagID: Word; const AValue: TTagEntry);
function GetTagByIndex(AIndex: Integer): TTagEntry;
procedure SetTagByIndex(AIndex: Integer; const AValue: TTagEntry);
function GetTagByName(ATagName: String): TTagEntry;
procedure SetTagByName(ATagName: String; const AValue: TTagEntry);
function GetTagValue(ATagName: String): variant;
procedure SetTagValue(ATagName: String; AValue: variant);
function GetTagValueAsString(ATagName: String): String;
procedure SetTagValueAsString(ATagName: String; AValue: String);
function GetThumbTagByID(ATagID: Word): TTagEntry;
procedure SetThumbTagByID(ATagID: Word; const AValue: TTagEntry);
function GetThumbTagByIndex(AIndex: Integer): TTagEntry;
procedure SetThumbTagByIndex(AIndex: Integer; const AValue: TTagEntry);
function GetThumbTagByName(ATagName: String): TTagEntry;
procedure SetThumbTagByName(ATagName: String; const AValue: TTagEntry);
function GetThumbTagValue(ATagName: String): Variant;
procedure SetThumbTagValue(ATagName: String; AValue: variant);
function GetThumbTagValueAsString(ATagName: String): string;
procedure SetThumbTagValueAsString(ATagName: String; AValue: String);
procedure InternalGetBinaryTagValue(const ATag: TTagEntry; var ABuffer: ansistring);
function InternalGetTagValue(const ATag: TTagEntry): Variant;
function InternalGetTagValueAsString(const ATag: TTagEntry): String;
procedure InternalSetTagValue(const ATagName: String; AValue: Variant;
ATagTypes: TTagTypes; ABinaryData: Pointer = nil; ABinaryDataCount: Word = 0);
function BinaryTagToStr(const ATag: TTagEntry): String;
function BinaryTagToVar(const ATag: TTagEntry): Variant;
function NumericTagToVar(ABuffer: Pointer; ATagType: Integer): Variant;
procedure VarToNumericTag(AValue:variant; ATag: PTagEntry);
// misc
function CreateTagPtr(const ATagDef: TTagEntry; IsThumbTag: Boolean; AParentID: Word = 0): PTagEntry;
function FindTagPtr(const ATagDef: TTagEntry; IsThumbTag: Boolean): PTagEntry;
(*
function GetTagPtr(ATagTypes: TTagTypes; ATagID: Word; AForceCreate: Boolean=false;
AParentID: word=0; ATagType: word=65535): PTagEntry;
*)
procedure RemoveTag(ATagTypes: TTagTypes; ATagID: Word; AParentID: Word=0);
procedure ClearDirStack;
procedure PushDirStack(dirStart, offsetbase: Integer);
function TestDirStack(dirStart, offsetbase: Integer): boolean;
protected
function AddTagToArray(ANewTag: iTag): integer;
function AddTagToThumbArray(ANewTag: iTag): integer;
procedure Calc35Equiv;
function CvtInt(ABuffer: Pointer; ABufferSize: Integer): Longint;
function Decode: Boolean;
function ExifDateToDateTime(ARawStr: ansistring): TDateTime;
// procedure ExtractThumbnail;
function FormatNumber(ABuffer: PByte; ABufferSize: Integer;
AFmt: integer; AFmtStr: string; ADecodeStr: string=''): String;
function GetNumber(ABuffer: PByte; ABufferSize: Integer;
AFmt: integer): double;
function LookupRatio: double;
public
MaxTag: integer;
// Height, Width, HPosn, WPosn: integer;
FlashUsed: integer;
BuildList: integer;
MakerNote: ansistring;
TiffFmt: boolean;
// Add support for thumbnail
ThumbTrace: ansistring;
MaxThumbTag: integer;
// Added the following elements to make the structure a little more code-friendly
TraceLevel: integer;
TraceStr: ansistring;
msTraceStr: ansistring;
msAvailable: boolean;
msName:ansistring;
MakerOffset : integer;
public
constructor Create(AParent: TObject; ABigEndian: Boolean;
ABuildCode: integer = GenAll);
procedure Assign(source: TImageInfo);
destructor Destroy; override;
// Reader interface
procedure AddTagFromReader(ATag: TTagEntry);
procedure AddThumbnailFromReader(ABuffer: TBytes);
// Date/time routines
procedure AdjDateTime(ADays, AHours, AMins, ASecs: integer);
function GetImgDateTime: TDateTime;
// Manufacturer-specific
procedure AddMSTag(ATagName: String; ARawStr: ansistring; AType: word);
// Iterate through found tags
procedure ResetIterator;
procedure ResetThumbIterator;
function IterateFoundTags(TagId:integer; var retVal:TTagEntry):boolean;
function IterateFoundThumbTags(TagId: integer;
var retVal: TTagEntry): boolean;
// Collective output
procedure EXIFArrayToXML(AList: TStrings); overload;
function ToShortString: String; // Summarizes in a single line
function ToLongString(ALabelWidth: Integer = 15): String;
// Special actions
procedure AdjExifSize(AHeight, AWidth: Integer);
// Looking up tags and tag values
function GetRawFloat(ATagName: String): double;
function GetRawInt(ATagName: String): integer;
function GetTagByDesc(SearchStr: String): TTagEntry;
function LookupTagIndex(ATagName: String): integer; virtual;
// function LookupTagVal(ATagName: String): String; virtual;
function LookupTagDefn(ATagName: String): integer;
function LookupTagByDesc(ADesc: String): integer;
function LookupTagInt(ATagName: String): integer;
// Tag values as variant
property TagValue[ATagName: String]: Variant
read GetTagValue write SetTagValue; default;
// Tag values as string
property TagValueAsString[ATagName: String]: String
read GetTagValueAsString write SetTagValueAsString;
// Accessing entire tag record
property TagByID[ATagID: Word]: TTagEntry
read GetTagByID write SetTagByID;
property TagByIndex[AIndex: Integer]: TTagEntry
read GetTagByIndex write SetTagByIndex;
property TagByName[ATagName: String]: TTagEntry
read GetTagByName write SetTagByName;
property TagCount: Integer
read fiTagCount;
property Artist: String
read GetArtist write SetArtist;
property CameraMake: String
read GetCameraMake write SetCameraMake;
property CameraModel: String
read GetCameraModel write SetCameraModel;
property Copyright: String
read GetCopyright write SetCopyright;
property DateTimeOriginal: TDateTime
read GetDateTimeOriginal write SetDateTimeOriginal;
property DateTimeDigitized: TDateTime
read GetDateTimeDigitized write SetDateTimeDigitized;
property DateTimeModified: TDateTime
read GetDateTimeModified write SetDateTimeModified;
property ExifComment: String
read GetExifComment write SetExifComment;
property ExifVersion: String
read FExifVersion;
property GPSLatitude: Extended
read GetGPSLatitude write SetGPSLatitude;
property GPSLongitude: Extended
read GetGPSLongitude write SetGPSLongitude;
property ImageDescription: String
read GetImageDescription write SetImageDescription;
property Height: Integer
read GetHeight write SetHeight;
property Width: Integer
read GetWidth write SetWidth;
public
// General processing, called internally
procedure ProcessExifDir(DirStart, OffsetBase, ExifLength: LongInt;
ATagType: TTagType = ttExif; APrefix: string=''; AParentID: word=0);
procedure ProcessHWSpecific(AMakerBuff: ansistring;
TagTbl: array of TTagEntry; ADirStart, AMakerOffset: Longint;
spOffset: integer = 0);
public
// Thumbnail
procedure CreateThumbnail(AThumbnailSize: Integer = DEFAULT_THUMBNAIL_SIZE);
function HasThumbnail: boolean;
// procedure ProcessThumbnail;
procedure RemoveThumbnail;
procedure LoadThumbnailFromStream(AStream: TStream);
procedure SaveThumbnailToStream(AStream: TStream);
property ThumbnailBuffer: TBytes
read FThumbnailBuffer;
property ThumbTagByID[ATagID: Word]: TTagEntry
read GetThumbTagByID write SetThumbTagByID;
property ThumbTagByIndex[AIndex: Integer]: TTagEntry
read GetThumbTagByIndex write SetThumbTagByIndex;
property ThumbTagCount: Integer
read fiThumbCount;
property ThumbTagValue[ATagName: String]: variant
read GetThumbTagValue write SetThumbTagValue;
property ThumbTagValueAsString[ATagName: String]: String
read GetThumbTagValueAsString;
property Parent: TObject
read FParent;
end; // TInfoData
var
CurTagArray: TImageInfo = nil;
fmtInt: tfmtInt = defIntFmt;
fmtReal: tfmtReal = defRealFmt;
fmtFrac: tfmtFrac = defFracFmt;
ExifNonThumbnailLength : integer;
ShowTags: integer;
ExifTrace: integer = 0;
function FindExifTagDefByID(ATagID: Word): PTagEntry;
function FindGPSTagDefByID(ATagID: Word): PTagEntry;
function FindExifTagDefByName(ATagName: String): PTagEntry;
function FindGPSTagDefByName(ATagName: String): PTagEntry;
function LookupType(idx: integer): String;
implementation
uses
fpeMetadata, fpeMsData;
const
// Compression Type Constants
JPEG_COMP_TYPE = 6;
TIFF_COMP_TYPE = 1;
GPSCnt = 32;
ExifTagCnt = 251; // NOTE: was 250 before, but "count" is 251
TotalTagCnt = GPSCnt + ExifTagCnt;
{ Many tags added based on Php4 source...
http://lxr.php.net/source/php4/ext/exif/exif.c
See also: https://sno.phy.queensu.ca/~phil/exiftool/TagNames/EXIF.html }
var
TagTable : array [0..ExifTagCnt-1] of TTagEntry =
// TagTable : array of TTagEntry =
// TagTable : TTagDefArray [0..ExifTagCnt] =
// TagTable: TTagDefArray =
((TID:0; TType:2; Tag:$0001; Count:1; Name:'InteroperabilityIndex' ), {0}
(TID:0; TType:7; Tag:$0002; Count:1; Name:'InteroperabilityVersion';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:4; Callback:VersionCallback),
(TID:0; TType:2; Tag:$000B; Count:1; Name:'ACDComment' ),
(TID:0; TType:4; Tag:$00FE; Count:1; Name:'NewSubfileType' ),
(TID:0; TType:3; Tag:$00FF; Count:1; Name:'SubfileType' ),
(TID:0; TType:4; Tag:$0100; ParentID:$0000; Count:1; Name:'ImageWidth'),
(TID:0; TType:4; Tag:$0101; ParentID:$0000; Count:1; Name:'ImageLength'),
(TID:0; TType:3; Tag:$0102; ParentID:$0000; Count:3; Name:'BitsPerSample'),
(TID:0; TType:3; Tag:$0103; ParentID:$0000; Count:1; Name:'Compression';
Desc:''; Code:'6:Jpeg,3:Uncompressed,1:TIFF'),
(TID:0; TType:3; Tag:$0106; ParentID:$0000; Count:1; Name:'PhotometricInterpretation';
Desc:''; Code:'1:Monochrome, 2:RGB, 6:YCbCr'),
(TID:0; TType:3; Tag:$010A; ParentID:$0000; Count:1; Name:'FillOrder'), {10}
(TID:0; TType:2; Tag:$010D; ParentID:$0000; Count:1; Name:'DocumentName'),
(TID:0; TType:2; Tag:$010E; ParentID:$0000; Count:1; Name:'ImageDescription'),
(TID:0; TType:2; Tag:$010F; ParentID:$0000; Count:1; Name:'Make'),
(TID:0; TType:2; Tag:$0110; ParentID:$0000; Count:1; Name:'Model'),
(TID:0; TType:4; Tag:$0111; ParentID:$0000; Count:1; Name:'StripOffsets'),
(TID:0; TType:3; Tag:$0112; ParentID:$0000; Count:1; Name:'Orientation';
Desc:''; Code:'1:Horizontal (normal),2:Mirror horizontal,3:Rotate 180,'+
'4:Mirror vertical,5:Mirror horizontal and rotate 270 CW,'+
'6:Rotate 90 CW,7:Mirror horizontal and rotate 90 CW,'+
'8:Rotate 270 CW'),
(TID:0; TType:3; Tag:$0115; ParentID:$0000; Count:1; Name:'SamplesPerPixel'),
(TID:0; TType:4; Tag:$0116; ParentID:$0000; Count:1; Name:'RowsPerStrip'),
(TID:0; TType:4; Tag:$0117; ParentID:$0000; Count:1; Name:'StripByteCounts'),
(TID:0; TType:3; Tag:$0118; ParentID:$0000; Count:1; Name:'MinSampleValue'), {20}
(TID:0; TType:3; Tag:$0119; ParentID:$0000; Count:1; Name:'MaxSampleValue'),
(TID:0; TType:5; Tag:$011A; ParentID:$0000; Count:1; Name:'XResolution'),
// Desc:''; Code:''; Data:''; Raw:''; FormatS:'%f'),
(TID:0; TType:5; Tag:$011B; ParentID:$0000; Count:1; Name:'YResolution'),
// Desc:''; Code:''; Data:''; Raw:''; FormatS:'%f'),
(TID:0; TType:3; Tag:$011C; ParentID:$0000; Count:1; Name:'PlanarConfiguration'),
(TID:0; TType:2; Tag:$011D; ParentID:$0000; Count:1; Name:'PageName'),
(TID:0; TType:5; Tag:$011E; ParentID:$0000; Count:1; Name:'XPosition'),
(TID:0; TType:5; Tag:$011F; ParentID:$0000; Count:1; Name:'YPosition'),
(TID:0; TType:0; Tag:$0120; ParentID:$0000; Count:1; Name:'FreeOffsets'),
(TID:0; TType:0; Tag:$0121; ParentID:$0000; Count:1; Name:'FreeByteCounts'),
(TID:0; TType:3; Tag:$0122; ParentID:$0000; Count:1; Name:'GrayReponseUnit'), {30}
(TID:0; TType:0; Tag:$0123; ParentID:$0000; Count:1; Name:'GrayReponseCurve'),
(TID:0; TType:0; Tag:$0124; ParentID:$0000; Count:1; Name:'T4Options'),
(TID:0; TType:0; Tag:$0125; ParentID:$0000; Count:1; Name:'T6Options'),
(TID:0; TType:3; Tag:$0128; ParentID:$0000; Count:1; Name:'ResolutionUnit';
Desc:''; Code:'1:None specified,2:inches,3:cm'),
(TID:0; TType:3; Tag:$0129; ParentID:$0000; Count:2; Name:'PageNumber'),
(TID:0; TType:3; Tag:$012D; ParentID:$0000; Count:768; Name:'TransferFunction'),
(TID:0; TType:2; Tag:$0131; ParentID:$0000; Count:1; Name:'Software'),
(TID:0; TType:2; Tag:$0132; ParentID:$0000; Count:1; Name:'DateTime'),
(TID:0; TType:2; Tag:$013B; ParentID:$0000; Count:1; Name:'Artist'),
(TID:0; TType:2; Tag:$013C; ParentID:$0000; Count:1; Name:'HostComputer'), {40}
(TID:0; TType:3; Tag:$013D; ParentID:$0000; Count:1; Name:'Predictor'),
(TID:0; TType:5; Tag:$013E; ParentID:$0000; Count:2; Name:'WhitePoint'),
(TID:0; TType:5; Tag:$013F; ParentID:$0000; Count:6; Name:'PrimaryChromaticities'),
(TID:0; TType:0; Tag:$0140; ParentID:$0000; Count:1; Name:'ColorMap'),
(TID:0; TType:3; Tag:$0141; ParentID:$0000; Count:2; Name:'HalfToneHints'),
(TID:0; TType:4; Tag:$0142; ParentID:$0000; Count:1; Name:'TileWidth'),
(TID:0; TType:4; Tag:$0143; ParentID:$0000; Count:1; Name:'TileLength'),
(TID:0; TType:0; Tag:$0144; ParentID:$0000; Count:1; Name:'TileOffsets'),
(TID:0; TType:0; Tag:$0145; ParentID:$0000; Count:1; Name:'TileByteCounts'),
(TID:0; TType:0; Tag:$014A; ParentID:$0000; Count:1; Name:'SubIFDs'), {50}
(TID:0; TType:3; Tag:$014C; ParentID:$0000; Count:1; Name:'InkSet'),
(TID:0; TType:0; Tag:$014D; ParentID:$0000; Count:1; Name:'InkNames'),
(TID:0; TType:0; Tag:$014E; ParentID:$0000; Count:1; Name:'NumberOfInks'),
(TID:0; TType:0; Tag:$0150; ParentID:$0000; Count:1; Name:'DotRange'),
(TID:0; TType:2; Tag:$0151; ParentID:$0000; Count:1; Name:'TargetPrinter'),
(TID:0; TType:0; Tag:$0152; ParentID:$0000; Count:1; Name:'ExtraSample'),
(TID:0; TType:0; Tag:$0153; ParentID:$0000; Count:1; Name:'SampleFormat'),
(TID:0; TType:0; Tag:$0154; ParentID:$0000; Count:1; Name:'SMinSampleValue'),
(TID:0; TType:0; Tag:$0155; ParentID:$0000; Count:1; Name:'SMaxSampleValue'),
(TID:0; TType:0; Tag:$0156; ParentID:$0000; Count:1; Name:'TransferRange'), {60}
(TID:0; TType:0; Tag:$0157; ParentID:$0000; Count:1; Name:'ClipPath'),
(TID:0; TType:0; Tag:$0158; ParentID:$0000; Count:1; Name:'XClipPathUnits'),
(TID:0; TType:0; Tag:$0159; ParentID:$0000; Count:1; Name:'YClipPathUnits'),
(TID:0; TType:0; Tag:$015A; ParentID:$0000; Count:1; Name:'Indexed'),
(TID:0; TType:0; Tag:$015B; ParentID:$0000; Count:1; Name:'JPEGTables'),
(TID:0; TType:0; Tag:$015F; ParentID:$0000; Count:1; Name:'OPIProxy'),
(TID:0; TType:0; Tag:$0200; ParentID:$0000; Count:1; Name:'JPEGProc'),
(TID:0; TType:4; Tag:$0201; ParentID:$0000; Count:1; Name:'JPEGInterchangeFormat';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:4),
(TID:0; TType:4; Tag:$0202; ParentID:$0000; Count:1; Name:'JPEGInterchangeFormatLength'),
(TID:0; TType:0; Tag:$0203; ParentID:$0000; Count:1; Name:'JPEGRestartInterval'), {70}
(TID:0; TType:0; Tag:$0205; ParentID:$0000; Count:1; Name:'JPEGLosslessPredictors'),
(TID:0; TType:0; Tag:$0206; ParentID:$0000; Count:1; Name:'JPEGPointTransforms'),
(TID:0; TType:0; Tag:$0207; ParentID:$0000; Count:1; Name:'JPEGQTables'),
(TID:0; TType:0; Tag:$0208; ParentID:$0000; Count:1; Name:'JPEGDCTables'),
(TID:0; TType:0; Tag:$0209; ParentID:$0000; Count:1; Name:'JPEGACTables'),
(TID:0; TType:5; Tag:$0211; ParentID:$0000; Count:3; Name:'YCbCrCoefficients'),
(TID:0; TType:3; Tag:$0212; ParentID:$0000; Count:2; Name:'YCbCrSubSampling'),
(TID:0; TType:3; Tag:$0213; ParentID:$0000; Count:1; Name:'YCbCrPositioning';
Desc:''; Code:'1:Centered,2:Co-sited'),
(TID:0; TType:5; Tag:$0214; ParentID:$0000; Count:6; Name:'ReferenceBlackWhite'),
(TID:0; TType:1; Tag:$02BC; ParentID:$0000; Count:1; Name:'ExtensibleMetadataPlatform'), {80}
(TID:0; TType:0; Tag:$0301; ParentID:$0000; Count:1; Name:'Gamma'),
(TID:0; TType:0; Tag:$0302; ParentID:$0000; Count:1; Name:'ICCProfileDescriptor'),
(TID:0; TType:0; Tag:$0303; ParentID:$0000; Count:1; Name:'SRGBRenderingIntent'),
(TID:0; TType:0; Tag:$0304; ParentID:$0000; Count:1; Name:'ImageTitle'),
(TID:0; TType:2; Tag:$1000; ParentID:$0000; Count:1; Name:'RelatedImageFileFormat'),
(TID:0; TType:3; Tag:$1001; ParentID:$0000; Count:1; Name:'RelatedImageWidth'),
(TID:0; TType:3; Tag:$1002; ParentID:$0000; Count:1; Name:'RelatedImageHeight'),
(TID:0; TType:0; Tag:$5001; ParentID:$0000; Count:1; Name:'ResolutionXUnit'),
(TID:0; TType:0; Tag:$5002; ParentID:$0000; Count:1; Name:'ResolutionYUnit'),
(TID:0; TType:0; Tag:$5003; ParentID:$0000; Count:1; Name:'ResolutionXLengthUnit'), {90}
(TID:0; TType:0; Tag:$5004; ParentID:$0000; Count:1; Name:'ResolutionYLengthUnit'),
(TID:0; TType:0; Tag:$5005; ParentID:$0000; Count:1; Name:'PrintFlags'),
(TID:0; TType:0; Tag:$5006; ParentID:$0000; Count:1; Name:'PrintFlagsVersion'),
(TID:0; TType:0; Tag:$5007; ParentID:$0000; Count:1; Name:'PrintFlagsCrop'),
(TID:0; TType:0; Tag:$5008; ParentID:$0000; Count:1; Name:'PrintFlagsBleedWidth'),
(TID:0; TType:0; Tag:$5009; ParentID:$0000; Count:1; Name:'PrintFlagsBleedWidthScale'),
(TID:0; TType:0; Tag:$500A; ParentID:$0000; Count:1; Name:'HalftoneLPI'),
(TID:0; TType:0; Tag:$500B; ParentID:$0000; Count:1; Name:'HalftoneLPIUnit'),
(TID:0; TType:0; Tag:$500C; ParentID:$0000; Count:1; Name:'HalftoneDegree'),
(TID:0; TType:0; Tag:$500D; ParentID:$0000; Count:1; Name:'HalftoneShape'), {100}
(TID:0; TType:0; Tag:$500E; ParentID:$0000; Count:1; Name:'HalftoneMisc'),
(TID:0; TType:0; Tag:$500F; ParentID:$0000; Count:1; Name:'HalftoneScreen'),
(TID:0; TType:0; Tag:$5010; ParentID:$0000; Count:1; Name:'JPEGQuality'),
(TID:0; TType:0; Tag:$5011; ParentID:$0000; Count:1; Name:'GridSize'),
(TID:0; TType:0; Tag:$5012; ParentID:$0000; Count:1; Name:'ThumbnailFormat'),
(TID:0; TType:0; Tag:$5013; ParentID:$0000; Count:1; Name:'ThumbnailWidth'),
(TID:0; TType:0; Tag:$5014; ParentID:$0000; Count:1; Name:'ThumbnailHeight'),
(TID:0; TType:0; Tag:$5015; ParentID:$0000; Count:1; Name:'ThumbnailColorDepth'),
(TID:0; TType:0; Tag:$5016; ParentID:$0000; Count:1; Name:'ThumbnailPlanes'),
(TID:0; TType:0; Tag:$5017; ParentID:$0000; Count:1; Name:'ThumbnailRawBytes'), {110}
(TID:0; TType:0; Tag:$5018; ParentID:$0000; Count:1; Name:'ThumbnailSize'),
(TID:0; TType:0; Tag:$5019; ParentID:$0000; Count:1; Name:'ThumbnailCompressedSize'),
(TID:0; TType:0; Tag:$501A; ParentID:$0000; Count:1; Name:'ColorTransferFunction'),
(TID:0; TType:0; Tag:$501B; ParentID:$0000; Count:1; Name:'ThumbnailData'),
(TID:0; TType:0; Tag:$5020; ParentID:$0000; Count:1; Name:'ThumbnailImageWidth'),
(TID:0; TType:0; Tag:$5021; ParentID:$0000; Count:1; Name:'ThumbnailImageHeight'),
(TID:0; TType:0; Tag:$5022; ParentID:$0000; Count:1; Name:'ThumbnailBitsPerSample'),
(TID:0; TType:0; Tag:$5023; ParentID:$0000; Count:1; Name:'ThumbnailCompression'),
(TID:0; TType:0; Tag:$5024; ParentID:$0000; Count:1; Name:'ThumbnailPhotometricInterp'),
(TID:0; TType:0; Tag:$5025; ParentID:$0000; Count:1; Name:'ThumbnailImageDescription'), {120}
(TID:0; TType:2; Tag:$5026; ParentID:$0000; Count:1; Name:'ThumbnailEquipMake'),
(TID:0; TType:2; Tag:$5027; ParentID:$0000; Count:1; Name:'ThumbnailEquipModel'),
(TID:0; TType:0; Tag:$5028; ParentID:$0000; Count:1; Name:'ThumbnailStripOffsets'),
(TID:0; TType:0; Tag:$5029; ParentID:$0000; Count:1; Name:'ThumbnailOrientation'),
(TID:0; TType:0; Tag:$502A; ParentID:$0000; Count:1; Name:'ThumbnailSamplesPerPixel'),
(TID:0; TType:0; Tag:$502B; ParentID:$0000; Count:1; Name:'ThumbnailRowsPerStrip'),
(TID:0; TType:0; Tag:$502C; ParentID:$0000; Count:1; Name:'ThumbnailStripBytesCount'),
(TID:0; TType:0; Tag:$502D; ParentID:$0000; Count:1; Name:'ThumbnailResolutionX'),
(TID:0; TType:0; Tag:$502E; ParentID:$0000; Count:1; Name:'ThumbnailResolutionY'),
(TID:0; TType:0; Tag:$502F; ParentID:$0000; Count:1; Name:'ThumbnailPlanarConfig'), {130}
(TID:0; TType:0; Tag:$5030; ParentID:$0000; Count:1; Name:'ThumbnailResolutionUnit'),
(TID:0; TType:0; Tag:$5031; ParentID:$0000; Count:1; Name:'ThumbnailTransferFunction'),
(TID:0; TType:2; Tag:$5032; ParentID:$0000; Count:1; Name:'ThumbnailSoftwareUsed'),
(TID:0; TType:2; Tag:$5033; ParentID:$0000; Count:1; Name:'ThumbnailDateTime'),
(TID:0; TType:2; Tag:$5034; ParentID:$0000; Count:1; Name:'ThumbnailArtist'),
(TID:0; TType:0; Tag:$5035; ParentID:$0000; Count:1; Name:'ThumbnailWhitePoint'),
(TID:0; TType:0; Tag:$5036; ParentID:$0000; Count:1; Name:'ThumbnailPrimaryChromaticities'),
(TID:0; TType:0; Tag:$5037; ParentID:$0000; Count:1; Name:'ThumbnailYCbCrCoefficients'),
(TID:0; TType:0; Tag:$5038; ParentID:$0000; Count:1; Name:'ThumbnailYCbCrSubsampling'),
(TID:0; TType:0; Tag:$5039; ParentID:$0000; Count:1; Name:'ThumbnailYCbCrPositioning'), {140}
(TID:0; TType:0; Tag:$503A; ParentID:$0000; Count:1; Name:'ThumbnailRefBlackWhite'),
(TID:0; TType:2; Tag:$503B; ParentID:$0000; Count:1; Name:'ThumbnailCopyRight'),
(TID:0; TType:0; Tag:$5090; ParentID:$0000; Count:1; Name:'LuminanceTable'),
(TID:0; TType:0; Tag:$5091; ParentID:$0000; Count:1; Name:'ChrominanceTable'),
(TID:0; TType:0; Tag:$5100; ParentID:$0000; Count:1; Name:'FrameDelay'),
(TID:0; TType:0; Tag:$5101; ParentID:$0000; Count:1; Name:'LoopCount'),
(TID:0; TType:0; Tag:$5110; ParentID:$0000; Count:1; Name:'PixelUnit'),
(TID:0; TType:0; Tag:$5111; ParentID:$0000; Count:1; Name:'PixelPerUnitX'),
(TID:0; TType:0; Tag:$5112; ParentID:$0000; Count:1; Name:'PixelPerUnitY'),
(TID:0; TType:0; Tag:$5113; ParentID:$0000; Count:1; Name:'PaletteHistogram'), {150}
(TID:0; TType:0; Tag:$800D; ParentID:$0000; Count:1; Name:'ImageID'),
(TID:0; TType:0; Tag:$80E3; ParentID:$0000; Count:1; Name:'Matteing'), //* obsoleted by ExtraSamples */
(TID:0; TType:0; Tag:$80E4; ParentID:$0000; Count:1; Name:'DataType'), //* obsoleted by SampleFormat */
(TID:0; TType:0; Tag:$80E5; ParentID:$0000; Count:1; Name:'ImageDepth'),
(TID:0; TType:0; Tag:$80E6; ParentID:$0000; Count:1; Name:'TileDepth'),
(TID:0; TType:3; Tag:$828D; ParentID:$0000; Count:2; Name:'CFARepeatPatternDim'),
(TID:0; TType:1; Tag:$828E; ParentID:$0000; Count:1; Name:'CFAPattern'), //count: ???
(TID:0; TType:0; Tag:$828F; ParentID:$0000; Count:1; Name:'BatteryLevel'),
(TID:0; TType:2; Tag:$8298; ParentID:$0000; Count:1; Name:'Copyright'),
(TID:0; TType:5; Tag:$829A; ParentID:$8769; Count:1; Name:'ExposureTime';
Desc:'Exposure time'; Code:''; Data:''; Raw:''; FormatS:'%s sec'; Size:8; Callback:nil), //SSpeedCallback), {160}
(TID:0; TType:5; Tag:$829D; ParentID:$8769; Count:1; Name:'FNumber';
Desc:''; Code:''; Data:''; Raw:''; FormatS:'F%0.1f'),
(TID:0; TType:4; Tag:$83BB; ParentID:$0000; Count:1; Name:'IPTC/NAA';
Desc:'IPTC/NAA'),
(TID:0; TType:0; Tag:$84E3; ParentID:$0000; Count:1; Name:'IT8RasterPadding'),
(TID:0; TType:0; Tag:$84E5; ParentID:$0000; Count:1; Name:'IT8ColorTable'),
(TID:0; TType:0; Tag:$8649; ParentID:$0000; Count:1; Name:'ImageResourceInformation'),
(TID:0; TType:4; Tag:$8769; ParentID:$0000; Count:1; Name:'ExifOffset';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:4),
(TID:0; TType:0; Tag:$8773; ParentID:$0000; Count:1; Name:'InterColorProfile'),
(TID:0; TType:3; Tag:$8822; ParentID:$8769; Count:1; Name:'ExposureProgram';
Desc:''; Code:'0:Not denfined,1:Manual,2:Program AE,3:Aperture-priority AE,'+
'4:Shutter speed priority AE,5:Creative (slow speed),'+
'6:Action (high speed),7:Portrait,8:Landscape;9:Bulb'),
(TID:0; TType:2; Tag:$8824; ParentID:$8769; Count:1; Name:'SpectralSensitivity'),
(TID:0; TType:4; Tag:$8825; ParentID:$0000; Count:1; Name:'GPSInfo';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:4), {170}
(TID:0; TType:3; Tag:$8827; ParentID:$8769; Count:1; Name:'ISOSpeedRatings'), {171}
(TID:0; TType:0; Tag:$8828; ParentID:$8769; Count:1; Name:'OECF'),
(TID:0; TType:0; Tag:$8829; ParentID:$8769; Count:1; Name:'Interlace'),
(TID:0; TType:8; Tag:$882A; ParentID:$8769; Count:1; Name:'TimeZoneOffset'),
(TID:0; TType:3; Tag:$882B; ParentID:$8769; Count:1; Name:'SelfTimerMode'),
(TID:0; TType:7; Tag:$9000; ParentID:$8769; Count:1; Name:'ExifVersion';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:4; Callback:VersionCallback),
(TID:0; TType:2; Tag:$9003; ParentID:$8769; Count:1; Name:'DateTimeOriginal'),
(TID:0; TType:2; Tag:$9004; ParentID:$8769; Count:1; Name:'DateTimeDigitized'),
(TID:0; TType:7; Tag:$9101; ParentID:$8769; Count:1; Name:'ComponentsConfiguration';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:0; Callback:CompCfgCallBack),
(TID:0; TType:5; Tag:$9102; ParentID:$8769; Count:1; Name:'CompressedBitsPerPixel'), {180}
(TID:0; TType:10; Tag:$9201; ParentID:$8769; Count:1; Name:'ShutterSpeedValue';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:0; Callback:SSpeedCallBack),
(TID:0; TType:5; Tag:$9202; ParentID:$8769; Count:1; Name:'ApertureValue';
Desc:'Aperture value'; Code:''; Data:''; Raw:''; FormatS:'F%0.1f'),
(TID:0; TType:10;Tag:$9203; ParentID:$8769; Count:1; Name:'BrightnessValue'),
(TID:0; TType:10;Tag:$9204; ParentID:$8769; Count:1; Name:'ExposureBiasValue'),
(TID:0; TType:5; Tag:$9205; ParentID:$8769; Count:1; Name:'MaxApertureValue';
Desc:''; Code:''; Data:''; Raw:''; FormatS:'F%0.1f'),
(TID:0; TType:5; Tag:$9206; ParentID:$8769; Count:1; Name:'SubjectDistance'),
(TID:0; TType:3; Tag:$9207; ParentID:$8769; Count:1; Name:'MeteringMode';
Desc:'';
Code:'0:Unknown,1:Average,2:Center,3:Spot,4:Multi-spot,5:Multi-segment,6:Partial'),
(TID:0; TType:3; Tag:$9208; ParentID:$8769; Count:1; Name:'LightSource';
Desc:'';
Code:'0:Unknown,1:Daylight,2:Fluorescent,3:Tungsten,10:Flash,17:Std A,18:Std B,19:Std C'),
(TID:0; TType:3; Tag:$9209; ParentID:$8769; Count:1; Name:'Flash';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:FlashCallBack),
(TID:0; TType:5; Tag:$920A; ParentID:$8769; Count:1; Name:'FocalLength';
Desc:'Focal length'; Code:''; Data:''; Raw:''; FormatS:'%0.1f mm'), {190}
(TID:0; TType:0; Tag:$920B; ParentID:$8769; Count:1; Name:'FlashEnergy'),
(TID:0; TType:0; Tag:$920C; ParentID:$8769; Count:1; Name:'SpatialFrequencyResponse'),
(TID:0; TType:0; Tag:$920D; ParentID:$8769; Count:1; Name:'Noise'),
(TID:0; TType:0; Tag:$920E; ParentID:$8769; Count:1; Name:'FocalPlaneXResolution';
Desc:''; code:''; Data:''; Raw:''; FormatS:'%f'; Size:0; CallBack:nil),
(TID:0; TType:0; Tag:$920F; ParentID:$8769; Count:1; Name:'FocalPlaneYResolution';
Desc:''; Code:''; Data:''; Raw:''; FormatS:'%f'; Size:0; CallBack:nil),
(TID:0; TType:0; Tag:$9210; ParentID:$8769; Count:1; Name:'FocalPlaneResolutionUnit';
Desc:''; Code:'1:None specified,2:inches,3:cm'),
(TID:0; TType:4; Tag:$9211; ParentID:$8769; Count:1; Name:'ImageNumber'),
(TID:0; TType:2; Tag:$9212; ParentID:$8769; Count:1; Name:'SecurityClassification'),
(TID:0; TType:2; Tag:$9213; ParentID:$8769; Count:1; Name:'ImageHistory'),
(TID:0; TType:3; Tag:$9214; ParentID:$8769; Count:2; Name:'SubjectLocation'), {200}
(TID:0; TType:0; Tag:$9215; ParentID:$8769; Count:1; Name:'ExposureIndex'),
(TID:0; TType:0; Tag:$9216; ParentID:$8769; Count:1; Name:'TIFF/EPStandardID'),
(TID:0; TType:0; Tag:$9217; ParentID:$8769; Count:1; Name:'SensingMethod'),
(TID:0; TType:0; Tag:$923F; ParentID:$8769; Count:1; Name:'StoNits'),
(TID:0; TType:7; Tag:$927C; ParentID:$8769; Count:1; Name:'MakerNote'),
(TID:0; TType:7; Tag:$9286; ParentID:$8769; Count:1; Name:'UserComment'),
(TID:0; TType:2; Tag:$9290; ParentID:$8769; Count:1; Name:'SubSecTime'),
(TID:0; TType:2; Tag:$9291; ParentID:$8769; Count:1; Name:'SubSecTimeOriginal'),
(TID:0; TType:2; Tag:$9292; ParentID:$8769; Count:1; Name:'SubSecTimeDigitized'),
(TID:0; TType:0; Tag:$953C; ParentID:$0000; Count:1; Name:'ImageSourceData'), // "Adobe Photoshop Document Data Block": 8BIM... {210}
(TID:0; TType:0; Tag:$9C9B; ParentID:$0000; Count:1; Name:'Title';
Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:xpTranslate), // Win XP specific, Unicode
(TID:0; TType:0; Tag:$9C9C; ParentID:$0000; Count:1; Name:'Comments';
Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:xpTranslate), // Win XP specific, Unicode
(TID:0; TType:0; Tag:$9C9D; ParentID:$0000; Count:1; Name:'Author';
Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:xpTranslate), // Win XP specific, Unicode
(TID:0; TType:0; Tag:$9C9E; ParentID:$0000; Count:1; Name:'Keywords';
Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:xpTranslate), // Win XP specific, Unicode
(TID:0; TType:0; Tag:$9C9F; ParentID:$0000; Count:1; Name:'Subject';
Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:xpTranslate), // Win XP specific, Unicode
(TID:0; TType:0; Tag:$A000; ParentID:$8769; Count:1; Name:'FlashPixVersion'),
(TID:0; TType:3; Tag:$A001; ParentID:$8769; Count:1; Name:'ColorSpace';
Desc:''; Code:'0:sBW,1:sRGB'),
(TID:0; TType:3; Tag:$A002; ParentID:$8769; Count:1; Name:'ExifImageWidth'),
(TID:0; TType:3; Tag:$A003; ParentID:$8769; Count:1; Name:'ExifImageLength'),
(TID:0; TType:2; Tag:$A004; ParentID:$8769; Count:1; Name:'RelatedSoundFile'), {220}
(TID:0; TType:0; Tag:$A005; ParentID:$8769; Count:1; Name:'InteroperabilityOffset'),
(TID:0; TType:5; Tag:$A20B; ParentID:$8769; Count:1; Name:'FlashEnergy'), // TID:0;TType:0;ICode: 2;Tag: $920B in TIFF/EP
(TID:0; TType:0; Tag:$A20C; ParentID:$8769; Count:1; Name:'SpatialFrequencyResponse'), // TID:0;TType:0;ICode: 2;Tag: $920C - -
(TID:0; TType:5; Tag:$A20E; ParentID:$8769; Count:1; Name:'FocalPlaneXResolution';
Desc:''; code:''; Data:''; Raw:''; FormatS:'%f'; Size:0; CallBack:nil),
(TID:0; TType:5; Tag:$A20F; ParentID:$8769; Count:1; Name:'FocalPlaneYResolution';
Desc:''; code:''; Data:''; Raw:''; FormatS:'%f'; Size:0; CallBack:nil),
(TID:0; TType:3; Tag:$A210; ParentID:$8769; Count:1; Name:'FocalPlaneResolutionUnit';
Desc:''; Code:'1:None specified,2:inches,3:cm'), // TID:0;TType:0;ICode: 2;Tag: $9210 - -
(TID:0; TType:0; Tag:$A211; ParentID:$8769; Count:1; Name:'ImageNumber'),
(TID:0; TType:0; Tag:$A212; ParentID:$8769; Count:1; Name:'SecurityClassification'),
(TID:0; TType:0; Tag:$A213; ParentID:$8769; Count:1; Name:'ImageHistory'),
(TID:0; TType:3; Tag:$A214; ParentID:$8769; Count:2; Name:'SubjectLocation'), {230}
(TID:0; TType:5; Tag:$A215; ParentID:$8769; Count:1; Name:'ExposureIndex'),
(TID:0; TType:0; Tag:$A216; ParentID:$8769; Count:1; Name:'TIFF/EPStandardID';
Desc:'TIFF/EPStandardID'),
(TID:0; TType:3; Tag:$A217; ParentID:$8769; Count:1; Name:'SensingMethod'; Desc:'';
Code:'0:Unknown,1:Not defined,2:One-chip color area,3:Two-chip color area,'+
'4:Three-chip color area,5:Color sequential area,7:Trilinear,'+
'8:Color-sequential linear'),
(TID:0; TType:1; Tag:$A300; ParentID:$8769; Count:1; Name:'FileSource'; Desc:'';
Code:'0:Unknown,1:Film scanner,2:Reflection print scanner,3:Digital camera'),
(TID:0; TType:7; Tag:$A301; ParentID:$8769; Count:1; Name:'SceneType';
Desc:''; Code:'0:Unknown,1:Directly Photographed'),
(TID:0; TType:7; Tag:$A302; ParentID:$8769; Count:1; Name:'CFAPattern'),
(TID:0; TType:3; Tag:$A401; ParentID:$8769; Count:1; Name:'CustomRendered';
Desc:''; Code:'0:Normal,1:Custom'),
(TID:0; TType:3; Tag:$A402; ParentID:$8769; Count:1; Name:'ExposureMode';
Desc:''; Code:'0:Auto,1:Manual,2:Auto bracket'),
(TID:0; TType:3; Tag:$A403; ParentID:$8769; Count:1; Name:'WhiteBalance';
Desc:''; Code:'0:Auto,1:Manual'),
(TID:0; TType:5; Tag:$A404; ParentID:$8769; Count:1; Name:'DigitalZoomRatio'), {240}
(TID:0; TType:3; Tag:$A405; ParentID:$8769; Count:1; Name:'FocalLengthIn35mmFilm';
Desc:'Focal Length in 35mm Film'; Code:''; Data:''; Raw:''; FormatS:'%.1f mm'),
(TID:0; TType:3; Tag:$A406; ParentID:$8769; Count:1; Name:'SceneCaptureType';
Desc:''; Code:'0:Standard,1:Landscape,2:Portrait,3:Night scene'),
(TID:0; TType:3; Tag:$A407; ParentID:$8769; Count:1; Name:'GainControl'; Desc:'';
Code:'0:None,1:Low gain up,2:High gain up,3:Low gain down,4:High gain down'),
(TID:0; TType:3; Tag:$A408; ParentID:$8769; Count:1; Name:'Contrast';
Desc:''; Code:'0:Normal,1:Soft,2:Hard'),
(TID:0; TType:3; Tag:$A409; ParentID:$8769; Count:1; Name:'Saturation';
Desc:''; Code:'0:Normal,1:Low,2:High'),
(TID:0; TType:3; Tag:$A40A; ParentID:$8769; Count:1; Name:'Sharpness';
Desc:''; Code:'0:Normal,1:Soft,2:Hard'),
(TID:0; TType:0; Tag:$A40B; ParentID:$8769; Count:1; Name:'DeviceSettingDescription'),
(TID:0; TType:3; Tag:$A40C; ParentID:$8769; Count:1; Name:'SubjectDistanceRange'; {250}
Desc:''; Code:'0:Unknown,1:Macro,2:Close view,3:Distant view'),
(TID:0; TType:2; Tag:$A420; ParentID:$8769; Count:1; Name:'ImageUniqueID';
Desc:''; Code:'0:Close view,1:Distant view'),
(TID:0; TType:0; Tag:0; ParentID:$0000; Count:1; Name:'Unknown')
);
GPSTable : array [0..GPSCnt-1] of TTagEntry = (
(TID:0; TType:1; Tag:$000; ParentID:$8825; Count:4; Name:'GPSVersionID';
Desc:''; Code:''; Data:''; RAw:''; FormatS:''; Size:0; CallBack:GpsVersionID),
(TID:0; TType:2; Tag:$001; ParentID:$8825; Count:2; Name:'GPSLatitudeRef'; Desc:''),
(TID:0; TType:5; Tag:$002; ParentID:$8825; Count:3; Name:'GPSLatitude';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:GpsPosn),
(TID:0; TType:2; Tag:$003; ParentID:$8825; Count:2; Name:'GPSLongitudeRef';Desc:''),
(TID:0; TType:5; Tag:$004; ParentID:$8825; Count:3; Name:'GPSLongitude';
Desc:''; Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:GpsPosn),
(TID:0; TType:1; Tag:$005; ParentID:$8825; Count:1; Name:'GPSAltitudeRef'; Desc:'';
Code:'0:Above Sealevel,1:Below Sealevel'),
(TID:0; TType:5; Tag:$006; ParentID:$8825; Count:1; Name:'GPSAltitude'; Desc:'';
Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:GpsAltitude),
(TID:0; TType:5; Tag:$007; ParentID:$8825; Count:3; Name:'GPSTimeStamp'; Desc:'';
Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:CvtTime),
(TID:0; TType:2; Tag:$008; ParentID:$8825; Count:1; Name:'GPSSatellites'; Desc:''),
(TID:0; TType:2; Tag:$009; ParentID:$8825; Count:2; Name:'GPSStatus';
Desc:''; Code:'A:Active;V:Void'),
(TID:0; TType:2; Tag:$00A; ParentID:$8825; Count:2; Name:'GPSMeasureMode';
Desc:''; Code:'2:2D,3:3D'),
(TID:0; TType:5; Tag:$00B; ParentID:$8825; Count:1; Name:'GPSDOP'; Desc:''),
(TID:0; TType:2; Tag:$00C; ParentID:$8825; Count:2; Name:'GPSSpeedRef';
Desc:''; Code:'K:km/h,M:mph,N:knots'),
(TID:0; TType:5; Tag:$00D; ParentID:$8825; Count:1; Name:'GPSSpeed'; Desc:''),
(TID:0; TType:2; Tag:$00E; ParentID:$8825; Count:2; Name:'GPSTrackRef';
Desc:''; Code:'M:Magnetic North,T:True North'),
(TID:0; TType:5; Tag:$00F; ParentID:$8825; Count:1; Name:'GPSTrack'; Desc:''),
(TID:0; TType:2; Tag:$010; ParentID:$8825; Count:2; Name:'GPSImageDirectionRef';
Desc:''; Code:'M:Magnetic North,T:True North'),
(TID:0; TType:5; Tag:$011; ParentID:$8825; Count:1; Name:'GPSImageDirection'; Desc:''),
(TID:0; TType:2; Tag:$012; ParentID:$8825; Count:1; Name:'GPSMapDatum'; Desc:''),
(TID:0; TType:2; Tag:$013; ParentID:$8825; Count:2; Name:'GPSDestLatitudeRef';
Desc:''; Code:'N:North,S:South'),
(TID:0; TType:5; Tag:$014; ParentID:$8825; Count:3; Name:'GPSDestLatitude'; Desc:'';
Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:GpsPosn),
(TID:0; TType:2; Tag:$015; ParentID:$8825; Count:2; Name:'GPSDestLongitudeRef';
Desc:''; Code: 'E:East,W:West'),
(TID:0; TType:5; Tag:$016; ParentID:$8825; Count:3; Name:'GPSDestLongitude'; Desc:'';
Code:''; Data:''; Raw:''; FormatS:''; Size:0; CallBack:GpsPosn),
(TID:0; TType:2; Tag:$017; ParentID:$8825; Count:2; Name:'GPSDestBearingRef';
Desc:''; Code:'M:Magnetic North,T:True North'),
(TID:0; TType:5; Tag:$018; ParentID:$8825; Count:1; Name:'GPSDestBearing'; Desc:''),
(TID:0; TType:2; Tag:$019; ParentID:$8825; Count:2; Name:'GPSDestDistanceRef';
Desc:''; Code:'K:Kilometers,M:Miles,N:Nautic Miles'),
(TID:0; TType:5; Tag:$01A; ParentID:$8825; Count:1; Name:'GPSDestDistance'; Desc:''),
(TID:0; TType:7; Tag:$01B; ParentID:$8825; Count:1; Name:'GPSProcessingMode'; Desc:''),
(TID:0; TType:7; Tag:$01C; ParentID:$8825; Count:1; Name:'GPSAreaInformation'; Desc:''),
(TID:0; TType:2; Tag:$01D; ParentID:$8825; Count:7; Name:'GPSDateStamp'; Desc:''),
(TID:0; TType:3; Tag:$01E; ParentID:$8825; Count:1; Name:'GPSDifferential';
Desc:''; Code:'0:No Correction,1:Differential Correction'),
(TID:0; TType:5; Tag:$01F; ParentID:$8825; Count:1; Name:'GPSHPositioningError'; Desc:'')
);
tagInit : boolean = false;
function FindExifTagDefByName(ATagName: String): PTagEntry;
var
i: Integer;
begin
for i:=0 to High(TagTable) do begin
Result := @TagTable[i];
if AnsiSameText(Result^.Name, ATagName) then
exit;
end;
Result := nil;
end;
function FindExifTagDefByID(ATagID: word): PTagEntry;
var
i: Integer;
begin
for i:=0 to High(TagTable) do begin
Result := @TagTable[i];
if Result^.Tag = ATagID then
exit;
end;
Result := nil;
end;
function FindGpsTagDefByName(ATagName: String): PTagEntry;
var
i: Integer;
begin
for i:=0 to High(GpsTable) do begin
Result := @GpsTable[i];
if AnsiSameText(Result^.Name, ATagName) then
exit;
end;
Result := nil;
end;
function FindGpsTagDefByID(ATagID: word): PTagEntry;
var
i: Integer;
begin
for i:=0 to High(GpsTable) do begin
Result := @GpsTable[i];
if Result^.Tag = ATagID then
exit;
end;
Result := nil;
end;
Procedure FixTagTable(var tags:array of TTagEntry);
var i:integer;
begin
for i := low(tags) to high(tags) do
begin
if Length(tags[i].Desc) <= 0 then
tags[i].Desc := tags[i].Name;
end;
end;
Procedure FixTagTableParse(var tags:array of TTagEntry);
var i:integer;
begin
for i := low(tags) to high(tags) do
begin
if Length(tags[i].Desc) <= 0 then
tags[i].Desc := InsertSpaces(tags[i].Name);
end;
end;
procedure LoadTagDescs(fancy:boolean = false);
begin
if tagInit
then exit
else tagInit := true;
if fancy then
begin
FixTagTableParse(TagTable);
FixTagTableParse(GPSTable);
end
else
begin
FixTagTable(TagTable);
FixTagTable(GPSTable);
end;
end;
function LookupMTagID(idx:integer; ManuTable: array of TTagEntry):integer;
var
i: integer;
begin
result := -1;
for i := 0 to high(ManuTable) do
if ManuTable[i].Tag = idx then
begin
result := i;
break;
end;
end;
function LookupType(idx: integer): String;
var
i: integer;
begin
result := 'Unknown';
// for i := 0 to (Sizeof(ProcessTable) div SizeOf(TTagEntry))-1 do
for i := 0 to High(ProcessTable) do
if ProcessTable[i].Tag = idx then begin
Result := ProcessTable[i].Desc;
exit;
end;
end;
function LookupTagDefByID(idx: integer; ATagType: TTagType = ttExif): integer;
var
i:integer;
begin
Result := -1;
case ATagType of
ttExif, ttThumb:
for i := 0 to ExifTagCnt-1 do
if TagTable[i].Tag = idx then begin
Result := i;
break;
end;
ttGps:
for i := 0 to GPSCnt-1 do
if GPSTable[i].Tag = idx then begin
Result := i;
break;
end;
end;
end;
function FetchTagDefByID(idx: integer; ATagType: TTagType = ttExif): TTagEntry;
var
i: integer;
begin
Result := TagTable[ExifTagCnt-1];
case ATagType of
ttExif, ttThumb:
for i := 0 to ExifTagCnt-1 do
if TagTable[i].Tag = idx then begin
result := TagTable[i];
break;
end;
ttGps:
for i := 0 to GPSCnt-1 do
if GPSTable[i].Tag = idx then begin
result := GPSTable[i];
break;
end;
end;
end;
function LookupCode(ATagID: Word; ATagType: TTagType=ttExif): String; overload;
var
i:integer;
begin
Result := '';
case ATagType of
ttExif, ttThumb:
for i := 0 to ExifTagCnt-1 do
if TagTable[i].Tag = ATagID then begin
Result := TagTable[i].Code;
break;
end;
ttGps:
for i := 0 to GPSCnt-1 do
if GPSTable[i].Tag = ATagID then begin
Result := GPSTable[i].Code;
break;
end;
end;
end;
function LookupCode(ATagID: Word; TagTbl: array of TTagEntry): String; overload;
var
i: integer;
begin
Result := '';
for i := 0 to High(TagTbl) do
if TagTbl[i].Tag = ATagID then begin
Result := TagTbl[i].Code;
break;
end;
end;
{ Tries to find the string AValue within TTagEntry.Code and
returns the numerical value assigned to the Code (before the colon).
Example:
The codes defined for the Tag "ResolutionUnits" are
'1:None Specified,2:Inch,3:Centimeter'.
If AValue is 'Inch' then the value 2 is returned. }
function GetTagCode(ATag: TTagEntry; AValue: String): Integer;
var
i: Integer;
begin
if ATag.Code <> '' then
Result := FindTextIndexInCode(AValue, ATag.Code)
else
if TryStrToInt(AValue, i) then
Result := i
else
Result := -1;
end;
//------------------------------------------------------------------------------
// TEndInd
//
// Here we implement the Endian Independent layer. Outside of these methods
// we don't care about endian issues.
//------------------------------------------------------------------------------
function TEndInd.GetDataBuff: AnsiString;
begin
result := FData;
end;
procedure TEndInd.SetDataBuff(const Value: AnsiString);
begin
FData := Value;
end;
procedure TEndInd.WriteInt16(var buff: AnsiString; int,posn: integer);
begin
if MotorolaOrder then
begin
buff[posn+1] := ansichar(int mod 256);
buff[posn] := ansichar(int div 256);
end
else
begin
buff[posn] := ansichar(int mod 256);
buff[posn+1] := ansichar(int div 256);
end
end;
procedure TEndInd.WriteInt32(var buff: ansistring; int, posn: longint);
begin
if MotorolaOrder then
begin
buff[posn+3] := ansichar(int mod 256);
buff[posn+2] := ansichar((int shr 8) mod 256);
buff[posn+1] := ansichar((int shr 16) mod 256);
buff[posn] := ansichar((int shr 24) mod 256);
end
else
begin
buff[posn] := ansichar(int mod 256);
buff[posn+1] := ansichar((int shr 8) mod 256);
buff[posn+2] := ansichar((int shr 16) mod 256);
buff[posn+3] := ansichar((int shr 24) mod 256);
end
end;
// Convert a 16 bit unsigned value from file's native byte order
function TEndInd.Get16u(AOffs: integer):word;
// var hibyte,lobyte:byte;
begin
// To help debug, uncomment the following two lines
// hibyte := byte(llData[oset+1]);
// lobyte := byte(llData[oset]);
if MotorolaOrder then
result := (byte(FData[AOffs]) shl 8) or byte(FData[AOffs+1])
else
result := (byte(FData[AOffs+1]) shl 8) or byte(FData[AOffs]);
end;
// Convert a 32 bit signed value from file's native byte order
function TEndInd.Get32s(AOffs: integer):Longint;
begin
if MotorolaOrder then
result := (byte(FData[AOffs]) shl 24)
or (byte(FData[AOffs+1]) shl 16)
or (byte(FData[AOffs+2]) shl 8)
or byte(FData[AOffs+3])
else
result := (byte(FData[AOffs+3]) shl 24)
or (byte(FData[AOffs+2]) shl 16)
or (byte(FData[AOffs+1]) shl 8)
or byte(FData[AOffs]);
end;
// Convert a 32 bit unsigned value from file's native byte order
function TEndInd.Put32s(data: Longint): AnsiString;
var
data2: integer;
// buffer: string[4] absolute data2;
// bbuff: AnsiChar;
begin
data2 := data;
if MotorolaOrder then
data2 := NtoBE(data) else
data2 := NtoLE(data);
SetLength(Result, 4);
Move(data2, Result[1], 4);
{
begin
bbuff := buffer[1];
buffer[1] := buffer[4];
buffer[4] := bbuff;
bbuff := buffer[2];
buffer[2] := buffer[3];
buffer[3] := bbuff;
end;
}
// Result := buffer;
end;
// Convert a 32 bit unsigned value from file's native byte order
function TEndInd.Get32u(AOffs: integer): Longword;
begin
result := Longword(Get32S(AOffs)) and $FFFFFFFF;
end;
{------------------------------------------------------------------------------}
{ TImageInfo }
{------------------------------------------------------------------------------}
constructor TImageInfo.Create(AParent: TObject; ABigEndian: Boolean;
ABuildCode: integer = GenAll);
begin
inherited Create;
FParent := AParent;
MotorolaOrder := ABigEndian;
LoadTagDescs(True); // initialize global structures
FITagCount := 0;
BuildList := ABuildCode;
ClearDirStack;
end;
// These destructors provided by Keith Murray of byLight Technologies - Thanks!
destructor TImageInfo.Destroy;
begin
SetLength(fITagArray, 0);
inherited;
end;
// To be called by the reader.
procedure TImageInfo.AddTagFromReader(ATag: TTagEntry);
begin
ATag.Data := InternalGetTagValueAsString(ATag);
if ATag.ParentID = 1 then
SetThumbTagByID(ATag.Tag, ATag)
else
SetTagByID(ATag.Tag, ATag);
end;
// To be called by the reader.
procedure TImageInfo.AddThumbnailFromReader(ABuffer: TBytes);
begin
SetLength(FThumbnailBuffer, Length(ABuffer));
if Length(ABuffer) > 0 then
Move(ABuffer[0], FThumbnailBuffer[0], Length(ABuffer));
end;
procedure TImageInfo.Assign(Source: TImageInfo);
begin
// FCameraMake := Source.FCameraMake;
// FCameraModel := Source.FCameraModel;
// DateTime := Source.DateTime;
Height := Source.Height;
Width := Source.Width;
FlashUsed := Source.FlashUsed;
// Comments := Source.Comments;
MakerNote := Source.MakerNote;
TraceStr := Source.TraceStr;
msTraceStr := Source.msTraceStr;
msAvailable := Source.msAvailable;
msName := Source.msName;
end;
function TImageInfo.GetTagByDesc(SearchStr: String): TTagEntry;
var
i: integer;
begin
i := LookupTagByDesc(SearchStr);
if i >= 0 then
Result := fiTagArray[i]
else
Result := EmptyEntry;
end;
// This function returns the index of a tag name in the tag buffer.
function TImageInfo.LookupTagIndex(ATagName: String): integer;
var
i: integer;
begin
ATagName := UpperCase(ATagName);
for i := 0 to fiTagCount-1 do
if UpperCase(fiTagArray[i].Name) = ATagName then
begin
Result := i;
Exit;
end;
Result := -1;
end;
(*
// This function returns the data value for a given tag name.
function TImageInfo.LookupTagVal(ATagName: String): String;
var
i: integer;
begin
ATagName := UpperCase(ATagName);
for i := 0 to fiTagCount-1 do
if UpperCase(fiTagArray[i].Name) = ATagName then
begin
Result := fiTagArray[i].Data;
Exit;
end;
Result := '';
end;
*)
// This function returns the integer data value for a given tag name.
function TImageInfo.LookupTagInt(ATagName: String):integer;
var
i: integer;
x: Double;
{$IFDEF FPC}
fs: TFormatSettings;
{$ELSE}
res: Integer;
{$ENDIF}
begin
ATagName := UpperCase(ATagName);
for i := 0 to fiTagCount-1 do
if UpperCase(fiTagArray[i].Name) = ATagName then
begin
if not TryStrToInt(fiTagArray[i].Data, Result) then
begin
if TryStrToFloat(fiTagArray[i].Data, x) then
Result := Round(x)
else
begin
{$IFDEF FPC}
fs := FormatSettings;
if fs.DecimalSeparator = '.' then fs.DecimalSeparator := ',' else
fs.DecimalSeparator := '.';
if TryStrToFloat(fiTagArray[i].Data, x, fs) then
Result := Round(x)
else
Result := -1;
{$ELSE}
val(fiTagArray[i].Data, x, res);
if res = 0 then
Result := Round(x)
else
Result := -1;
{$ENDIF}
end;
end;
Exit;
end;
Result := -1;
end;
// This function returns the index of a tag in the tag buffer.
// It searches by the description which is most likely to be used as a label
Function TImageInfo.LookupTagByDesc(ADesc: String):integer;
var
i: integer;
begin
ADesc := UpperCase(ADesc);
for i := 0 to FITagCount-1 do
if UpperCase(fiTagArray[i].Desc) = ADesc then
begin
Result := i;
Exit;
end;
Result := -1;
end;
// This function returns the index of a tag definition for a given tag name.
function TImageInfo.LookupTagDefn(ATagName: String): integer;
var
i: integer;
begin
for i := 0 to ExifTagCnt-1 do
begin
if LowerCase(ATagName) = LowerCase(TagTable[i].Name) then
begin
Result := i;
Exit;
end;
end;
Result := -1;
end;
function TImageInfo.ExifDateToDateTime(ARawStr: ansistring): TDateTime;
type
TConvert= packed record
year: Array [1..4] of ansichar; f1:ansichar;
mon: Array [1..2] of ansichar; f2:ansichar;
day: Array [1..2] of ansichar; f3:ansichar;
hr: Array [1..2] of ansichar; f4:ansichar;
min: Array [1..2] of ansichar; f5:ansichar;
sec: Array [1..2] of ansichar;
end;
PConvert= ^TConvert;
var
yr, mn, dy, h, m, s: Integer;
d: TDateTime;
t: TDateTime;
begin
Result := 0;
if Length(ARawStr) >= SizeOf(TConvert) then
with PConvert(@ARawStr[1])^ do
if TryStrToInt(year, yr) and
TryStrToInt(mon, mn) and
TryStrToInt(day, dy) and
TryEncodeDate(yr, mn, dy, d)
and
TryStrToInt(hr, h) and
TryStrToInt(min, m) and
TryStrToInt(sec, s) and
TryEncodeTime(h, m, s, 0, t)
then
Result := d + t;
end;
function TImageInfo.GetImgDateTime: TDateTime;
begin
Result := GetDateTimeOriginal;
if Result = 0 then
Result := GetDateTimeDigitized;
if Result = 0 then
Result := GetDateTimeModified;
if Result = 0 then
Result := TImgData(Parent).FileDatetime;
end;
function TImageInfo.GetDateTimeOriginal: TDateTime;
var
t: TTagEntry;
begin
Result := 0.0;
t := TagByName['DateTimeOriginal'];
if t.Tag <> 0 then
Result := ExifDateToDateTime(t.Raw);
end;
procedure TImageInfo.SetDateTimeOriginal(const AValue: TDateTime);
var
v: Variant;
begin
v := FormatDateTime(EXIF_DATETIME_FORMAT, AValue);
SetTagValue('DateTimeOriginal', v);
end;
function TImageInfo.GetDateTimeDigitized: TDateTime;
var
t: TTagEntry;
begin
Result := 0.0;
t := TagByName['DateTimeDigitized'];
if t.Tag <> 0 then
Result := ExifDateToDateTime(t.Raw);
end;
procedure TImageInfo.SetDateTimeDigitized(const AValue: TDateTime);
var
v: Variant;
begin
v := FormatDateTime(EXIF_DATETIME_FORMAT, AValue);
SetTagValue('DateTimeDigitized', v);
end;
function TImageInfo.GetDateTimeModified: TDateTime;
var
t: TTagEntry;
begin
Result := 0.0;
t := TagByName['DateTime'];
if t.Tag <> 0 then
Result := ExifDateToDateTime(t.Raw);
end;
procedure TImageInfo.SetDateTimeModified(const AValue: TDateTime);
var
v: Variant;
begin
v := FormatDateTime(EXIF_DATETIME_FORMAT, AValue);
SetTagValue('DateTime', v);
end;
Procedure TImageInfo.AdjDateTime(ADays, AHours, AMins, ASecs: Integer);
var
delta: double;
dt: TDateTime;
begin
// hrs/day min/day sec/day
delta := ADays + (AHours/24) + (AMins/1440) + (ASecs/86400);
dt := GetDateTimeOriginal;
if dt > 0 then SetDateTimeOriginal(dt + delta);
dt := GetDateTimeDigitized;
if dt > 0 then SetDateTimeDigitized(dt + delta);
dt := GetDateTimeModified;
if dt > 0 then SetDateTimeModified(dt + delta);
end;
function TImageInfo.AddTagToArray(ANewTag:iTag):integer;
begin
if not ((ANewTag.Name = '') or (ANewTag.Name = 'Unknown')) then // Empty fields are masked out
begin
if fITagCount >= MaxTag-1 then
begin
inc(MaxTag, TagArrayGrowth);
SetLength(fITagArray, MaxTag);
end;
fITagArray[fITagCount] := ANewTag;
inc(fITagCount);
end;
result := fITagCount-1;
end;
function TImageInfo.AddTagToThumbArray(ANewTag: iTag): integer;
begin
if ANewTag.Tag <> 0 then // Empty fields are masked out
begin
if fIThumbCount >= MaxThumbTag-1 then
begin
inc(MaxThumbTag, TagArrayGrowth);
SetLength(fIThumbArray, MaxThumbTag);
end;
fIThumbArray[fIThumbCount] := ANewTag;
inc(fIThumbCount);
end;
result := fIThumbCount-1;
end;
function TImageInfo.CvtInt(ABuffer: Pointer; ABufferSize: Integer): Longint;
var
i: integer;
r: Int64;
P: PByte;
begin
r := 0;
if MotorolaOrder then begin
P := PByte(ABuffer);
for i := 1 to ABufferSize do begin
r := r*256 + P^;
inc(P);
end;
end else begin
P := PByte(ABuffer);
inc(P, ABufferSize - 1);
for i := 1 to ABufferSize do begin
r := r*256 + P^;
dec(P);
end;
end;
Result := LongInt(r);
end;
function TImageInfo.Decode: Boolean;
begin
Result := TImgData(FParent).Decode;
end;
function TImageInfo.FormatNumber(ABuffer: PByte; ABufferSize: Integer;
AFmt: integer; AFmtStr: String; ADecodeStr: String=''): String;
var
P: PByte;
i, len: integer;
tmp, tmp2: longint;
dv: double;
begin
Result := '';
len := BYTES_PER_FORMAT[AFmt];
if len = 0 then
exit;
P := ABuffer;
for i := 0 to min(ABufferSize div len, 128) - 1 do
begin
if Result <> '' then
Result := Result + dExifDataSep; // Used for data display
case AFmt of
FMT_SBYTE,
FMT_BYTE,
FMT_USHORT,
FMT_ULONG,
FMT_SSHORT,
FMT_SLONG:
begin
tmp := CvtInt(P, len);
if (ADecodeStr = '') or not Decode then
Result := Result + defIntFmt(tmp)
else
Result := Result + DecodeField(ADecodeStr, IntToStr(tmp));
end;
FMT_URATIONAL,
FMT_SRATIONAL:
begin
tmp := CvtInt(P, 4);
inc(P, 4);
tmp2 := CvtInt(P, 4);
dec(P, 4);
Result := Result + defFracFmt(tmp, tmp2);
if (ADecodeStr <> '') or not Decode then
Result := Result + DecodeField(ADecodeStr, Result);
end;
FMT_SINGLE,
FMT_DOUBLE:
begin
// not used anyway; not sure how to interpret endian issues
Result := Result + '-9999.99';
end;
FMT_BINARY:
if ABufferSize = 1 then begin
tmp := CvtInt(P, 1);
if (ADecodeSTr = '') or not Decode then
Result := Result + DefIntFmt(tmp)
else
Result := Result + DecodeField(ADecodeStr, IntToStr(tmp));
end else
Result := Result + '?';
else
Result := Result + '?';
end;
inc(P, len);
end;
if AFmtStr <> '' then
begin
if Pos('%s', AFmtStr) > 0 then
Result := Format(AFmtStr, [Result], dExifFmtSettings)
else begin
dv := GetNumber(ABuffer, ABufferSize, AFmt); // wp: Will this always work?
Result := Format(AFmtStr, [dv], dExifFmtSettings);
end;
end;
end;
function TImageInfo.GetNumber(ABuffer: PByte; ABufferSize: Integer;
AFmt:integer): Double;
var
tmp: Longint;
tmp2: Longint;
begin
Result := 0;
try
case AFmt of
FMT_SBYTE,
FMT_BYTE,
FMT_USHORT,
FMT_ULONG,
FMT_SSHORT,
FMT_SLONG:
Result := CvtInt(ABuffer, ABufferSize);
FMT_URATIONAL,
FMT_SRATIONAL:
begin
tmp := CvtInt(ABuffer, 4);
inc(ABuffer, 4);
tmp2 := CvtInt(ABuffer, 4);
Result := tmp / tmp2;
end;
FMT_SINGLE:
Result := PSingle(ABuffer)^;
FMT_DOUBLE:
Result := PDouble(ABuffer)^;
end;
except
end;
end;
var
dirStack: String = '';
procedure TImageInfo.ClearDirStack;
begin
dirStack := '';
end;
procedure TImageInfo.PushDirStack(dirStart, offsetbase:longint);
var
ts: String;
begin
ts := '[' + IntToStr(offsetbase) + ':' + IntToStr(dirStart) + ']';
dirStack := dirStack + ts;
end;
function TImageInfo.TestDirStack(dirStart, offsetbase: Longint): boolean;
var
ts: String;
begin
ts := '[' + IntToStr(offsetbase) + ':' + IntToStr(dirStart) + ']';
result := Pos(ts,dirStack) > 0;
end;
(*
//{$DEFINE CreateExifBufDebug} // uncomment to see written Exif data
{$ifdef CreateExifBufDebug}var CreateExifBufDebug : String;{$endif}
function TImageInfo.CreateExifBuf(ParentID:word=0; OffsetBase:integer=0): AnsiString;
{offsetBase required, because the pointers of subIFD are referenced from parent IFD (WTF!!)}
// msta Creates APP1 block with IFD0 only
var
i, f, n: integer;
size, pDat, p: Cardinal;
head: ansistring;
function Check (const t: TTagEntry; pid: word): Boolean; //inline;
var
i: integer;
begin
if (t.parentID <> pid) or (t.TType >= Length(BYTES_PER_FORMAT)) or
(BYTES_PER_FORMAT[t.TType] = 0)
then
Result := false
else begin
Result := Length(whitelist) = 0;
for i := 0 to Length(whitelist)-1 do if (whitelist[i] = t.Tag) then begin
Result := true;
break;
end;
end;
end;
function CalcSubIFDSize(pid : integer) : integer;
var
i: integer;
begin
Result := 6;
for i := 0 to Length(fiTagArray)-1 do begin
if (not check(fiTagArray[i], pid)) then continue;
Result := Result + 12;
if (fiTagArray[i].id <> 0) then
Result := Result + calcSubIFDSize(fiTagArray[i].id)
else
if (Length(fiTagArray[i].Raw) > 4) then
Result := Result + Length(fiTagArray[i].Raw); // calc size
end;
end;
begin
{$ifdef CreateExifBufDebug}
if (parentID = 0) then CreateExifBufDebug := '';
{$endif}
if (parentID = 0) then
head := #0#0 // APP1 block size (calculated later)
+ 'Exif' + #$00+#$00 // Exif Header
+ 'II' + #$2A+#$00 + #$08+#$00+#$00+#$00 // TIFF Header (Intel)
else
head := '';
n := 0;
size := 0;
// for i := 0 to Length(fiTagArray)-1 do begin
for i := 0 to fiTagCount-1 do begin
if (not Check(fiTagArray[i], parentID)) then
continue;
n := n + 1; // calc number of Tags in current IFD
if (fiTagArray[i].id <> 0) then
size := size + CalcSubIFDSize(fiTagArray[i].id)
else
if (Length(fiTagArray[i].Raw) > 4) then
size := size + Length(fiTagArray[i].Raw); // calc size
end;
pDat := Length(head) + 2 + n*12 + 4; // position of data area
p := pDat;
size := size + pDat;
SetLength(Result, size);
if (parentID = 0) then begin
head[1] := ansichar(size div 256);
head[2] := ansichar(size mod 256);
move(head[1], Result[1], Length(head)); // write header
end;
PWord(@Result[1+Length(head)])^ := n; // write tag count
PCardinal(@Result[1+Length(head)+2+12*n])^ := 0; // write offset to next IFD (0, because just IFD0 is included)
n := 0;
for f := 0 to 1 do for i := 0 to Length(fiTagArray)-1 do begin // write tags
if (not check(fiTagArray[i], parentID)) then continue;
if (f = 0) and (fiTagArray[i].Tag <> TAG_EXIF_OFFSET) then
continue; // Sub-IFD must be first data block... more or less (WTF)
if (f = 1) and (fiTagArray[i].Tag = TAG_EXIF_OFFSET) then
continue;
PWord(@Result[1+Length(head)+2+12*n+0])^ := fiTagArray[i].Tag;
if (fiTagArray[i].Tag = TAG_EXIF_OFFSET) then begin
PWord(@Result[1+Length(head)+2+12*n+2])^ := 4; // Exif-Pointer is not a real data block but really a pointer (WTF)
PCardinal(@Result[1+Length(head)+2+12*n+4])^ := 1;
end
else begin
PWord(@Result[1+Length(head)+2+12*n+2])^ := fiTagArray[i].TType;
PCardinal(@Result[1+Length(head)+2+12*n+4])^ := Length(fiTagArray[i].Raw) div BYTES_PER_FORMAT[fiTagArray[i].TType];
end;
{$ifdef CreateExifBufDebug}CreateExifBufDebug := CreateExifBufDebug + ' ' + fiTagArray[i].Name;{$endif}
if (Length(fiTagArray[i].Raw) <= 4) and (fiTagArray[i].id = 0) then begin
PCardinal(@Result[1+Length(head)+2+12*n+8])^ := 0;
if (Length(fiTagArray[i].Raw) > 0) then
move(fiTagArray[i].Raw[1], Result[1+Length(head)+2+12*n+8], Length(fiTagArray[i].Raw));
end
else begin
PCardinal(@Result[1+Length(head)+2+12*n+8])^ := p - 8 + offsetBase;
if (fiTagArray[i].id <> 0) then begin
{$ifdef CreateExifBufDebug}CreateExifBufDebug := CreateExifBufDebug + ' { ';{$endif}
fiTagArray[i].Raw := CreateExifBuf(fiTagArray[i].id, p); // create sub IFD
fiTagArray[i].Size := Length(fiTagArray[i].Raw);
{$ifdef CreateExifBufDebug}CreateExifBufDebug := CreateExifBufDebug + ' } ';{$endif}
end;
move(fiTagArray[i].Raw[1], Result[1+p], Length(fiTagArray[i].Raw));
p := p + Length(fiTagArray[i].Raw);
end;
n := n+1;
end;
{$ifdef CreateExifBufDebug}if (parentID = 0) then ShowMessage(CreateExifBufDebug);{$endif}
end; *)
//--------------------------------------------------------------------------
// Process one of the nested EXIF directories.
//--------------------------------------------------------------------------
procedure TImageInfo.ProcessExifDir(DirStart, OffsetBase, ExifLength: longint;
ATagType: TTagType = ttExif; APrefix: string=''; AParentID: word = 0);
var
byteCount: integer;
tag, tagFormat, tagComponents: integer;
de, dirEntry, offsetVal, numDirEntries, valuePtr, subDirStart: Longint;
value: Integer;
rawStr, fStr, transStr: ansistring;
msInfo: TMsInfo;
lookupEntry, newEntry: TTagEntry;
tmpTR: ansistring;
tagID: word;
begin
PushDirStack(DirStart, OffsetBase);
numDirEntries := Get16u(DirStart);
if (ExifTrace > 0) then
TraceStr := TraceStr + crlf +
Format('Directory: Start, entries = %d, %d', [DirStart, numDirEntries]);
if (DirStart + 2 + numDirEntries*12) > (DirStart + OffsetBase + ExifLength) then
begin
TImgData(FParent).SetError('Illegally sized directory');
exit;
end;
// Uncomment to trace directory structure
{
Parent.ErrStr:=
Format('%d,%d,%d,%d+%s', [DirStart, numDirEntries,OffsetBase,ExifLength, parent.ErrStr]);
}
if (ATagType = ttExif) and (FThumbStart = 0) and not TiffFmt then
begin
DirEntry := DirStart + 2 + 12*numDirEntries;
FThumbStart := Get32u(DirEntry);
FThumbLength := OffsetBase + ExifLength - FThumbStart;
end;
for de := 0 to numDirEntries-1 do
begin
tagID := 0;
dirEntry := DirStart + 2 + 12*de;
tag := Get16u(dirEntry);
tagFormat := Get16u(dirEntry + 2);
tagComponents := Get32u(dirEntry + 4);
byteCount := tagComponents * BYTES_PER_FORMAT[tagFormat];
if byteCount = 0 then
Continue;
if byteCount > 4 then
begin
offsetVal := Get32u(dirEntry+8);
valuePtr := OffsetBase + offsetVal;
end
else
valuePtr := dirEntry + 8;
rawStr := Copy(TImgData(FParent).EXIFsegment^.Data, valuePtr, byteCount);
fStr := '';
if BuildList in [GenString, GenAll] then
begin
lookUpEntry := FetchTagDefByID(tag, ATagType);
with lookUpEntry do
begin
case tagFormat of
FMT_UNDEFINED:
fStr := '"' + StrBefore(rawStr, #0) + '"';
FMT_STRING:
begin
fStr := Copy(TImgData(FParent).EXIFsegment^.Data, valuePtr, byteCount);
if fStr[byteCount] = #0 then
Delete(fStr, byteCount, 1);
end;
else
fStr := FormatNumber(@rawStr[1], Length(rawStr), tagFormat, FormatS, Code);
end;
if ((tag > 0) or (lookupEntry.Name <> 'Unknown')) and Assigned(Callback) and Decode then
fStr := Callback(fStr)
else
fStr := MakePrintable(fStr);
transStr := Desc;
end;
case tag of
TAG_USERCOMMENT:
// strip off comment header
fStr := trim(Copy(rawStr, 9, byteCount-8));
TAG_DATETIME_MODIFY,
TAG_DATETIME_ORIGINAL,
TAG_DATETIME_DIGITIZED:
fStr := FormatDateTime(TImgData(FParent).DateTimeFormat, ExifDateToDateTime(fStr));
end;
// Update trace strings
tmpTR := crlf +
siif(ExifTrace > 0, 'tag[$' + IntToHex(tag,4) + ']: ', '') +
transStr + dExifDelim + fStr +
siif(ExifTrace > 0, ' [size: ' + IntToStr(byteCount) + ']', '') +
siif(ExifTrace > 0, ' [start: ' + IntToStr(valuePtr) + ']', '');
if ATagType = ttThumb then
Thumbtrace := ThumbTrace + tmpTR
else
TraceStr := TraceStr + tmpTR;
end;
// Additional processing done here:
case tag of
TAG_SUBIFD_OFFSET,
TAG_EXIF_OFFSET,
TAG_INTEROP_OFFSET:
begin
try
value := Get32u(valuePtr);
subdirStart := OffsetBase + LongInt(value);
// some mal-formed images have recursive references...
// if (subDirStart <> DirStart) then
if not TestDirStack(subDirStart, OffsetBase) then begin
tagID := tag;
ProcessExifDir(subdirStart, OffsetBase, ExifLength, ttExif, '', tagID);
end;
except
end;
end;
TAG_GPS_OFFSET:
begin
try
subdirStart := OffsetBase + LongInt(Get32u(ValuePtr));
if not TestDirStack(subDirStart, OffsetBase) then begin
tagID := tag;
ProcessExifDir(subdirStart, OffsetBase, ExifLength, ttGps, '', tagID);
end;
except
end;
end;
TAG_EXIFVERSION:
FExifVersion := rawstr;
TAG_MAKERNOTE:
begin
MakerNote := rawStr;
MakerOffset := valuePtr;
msInfo := TMsInfo.Create(TiffFmt, self);
msAvailable := msInfo.ReadMSData(self);
FreeAndNil(msInfo);
end;
TAG_FLASH:
FlashUsed := round(getNumber(@rawStr[1], Length(rawSTr), tagFormat));
(*
TAG_IMAGELENGTH,
TAG_EXIF_IMAGELENGTH:
begin
HPosn := DirEntry + 8;
Height := round(GetNumber(rawStr, tagFormat));
end;
TAG_IMAGEWIDTH,
TAG_EXIF_IMAGEWIDTH:
begin
WPosn := DirEntry + 8;
Width := round(GetNumber(rawStr, tagFormat));
end;
*)
TAG_THUMBSTARTOFFSET:
FThumbnailStartOffset := Get32u(ValuePtr);
TAG_THUMBSIZE:
FThumbnailSize := Get32u(ValuePtr);
TAG_COMPRESSION:
if ATagType = ttThumb then
FThumbType := round(GetNumber(@rawStr[1], Length(rawStr), tagFormat));
end;
if BuildList in [GenList,GenAll] then
begin
try
NewEntry := LookupEntry;
NewEntry.Data := fStr;
NewEntry.Raw := rawStr;
NewEntry.Size := Length(rawStr);
NewEntry.TType := tagFormat;
NewEntry.Count := tagComponents;
NewEntry.ParentID := AParentID;
NewEntry.TID := GenericEXIF; // 0
if ATagType = ttThumb then
AddTagToThumbArray(newEntry)
else
AddTagToArray(newEntry);
except
// if we're here: unknown tag.
// item is recorded in trace string
end;
end;
end;
if (ATagType = ttExif) and
((TImgData(FParent).ErrStr = '') or (TImgData(FParent).ErrStr = NO_ERROR))
then
Calc35Equiv();
end;
procedure TImageInfo.ProcessHWSpecific(AMakerBuff: ansistring;
TagTbl: array of TTagEntry; ADirStart, AMakerOffset: Longint;
spOffset: Integer = 0);
var
NumDirEntries: integer;
de, ByteCount, tagID: integer;
DirEntry, tag, tagFormat, tagComponents: integer;
OffsetVal, ValuePtr: Longint;
rawStr: ansistring;
tagStr: String;
fStr, fStr2, ds: ansistring;
OffsetBase: longint;
NewEntry: TTagEntry;
begin
ADirStart := ADirStart+1;
OffsetBase := ADirStart - AMakerOffset + 1;
SetDataBuff(AMakerBuff);
try
NumDirEntries := Get16u(ADirStart);
for de := 0 to NumDirEntries-1 do
begin
DirEntry := ADirStart + 2 + 12*de;
tag := Get16u(DirEntry);
tagFormat := Get16u(DirEntry+2);
tagComponents := Get32u(DirEntry+4);
ByteCount := tagComponents * BYTES_PER_FORMAT[tagFormat];
OffsetVal := 0;
if ByteCount > 4 then
begin
OffsetVal := Get32u(DirEntry + 8);
ValuePtr := OffsetBase + OffsetVal;
end
else
ValuePtr := DirEntry + 8;
// Adjustment needed by Olympus Cameras
if ValuePtr + ByteCount > Length(AMakerBuff) then
rawStr := Copy(TImgData(FParent).DataBuff, OffsetVal + spOffset, ByteCount)
else
rawStr := copy(AMakerBuff, ValuePtr, ByteCount);
tagID := LookupMTagID(tag, TagTbl);
if tagID < 0 then
tagStr := 'Unknown'
else
tagStr := TagTbl[tagID].Desc;
fstr := '';
if UpperCase(tagStr) = 'SKIP' then
continue;
if BuildList in [GenList, GenAll] then
begin
case tagFormat of
FMT_STRING:
fStr := '"' + StrBefore(rawStr, #0) + '"';
FMT_UNDEFINED:
fStr := '"' + rawStr + '"';
else
try
ds := siif(Decode, LookupCode(tag, TagTbl), '');
if tagID < 0 then
fStr := FormatNumber(@rawStr[1], Length(rawStr), tagFormat, '', '')
else
fStr := FormatNumber(@rawStr[1], Length(rawStr), tagFormat, TagTbl[tagID].FormatS, ds);
except
fStr := '"' + rawStr + '"';
end;
end;
rawDefered := false;
if (tagID > 0) and Assigned(TagTbl[tagID].CallBack) and Decode then
fstr2 := TagTbl[tagID].CallBack(fstr)
else
fstr2 := MakePrintable(fstr);
if (ExifTrace > 0) then
begin
if not rawDefered then
msTraceStr := msTraceStr + crlf +
'tag[$' + IntToHex(tag, 4) + ']: ' +
TagStr + dExifDelim + fstr2 +
' [size: ' + IntToStr(ByteCount) + ']' +
' [raw: ' + MakeHex(rawStr) + ']' +
' [start: ' + IntToStr(ValuePtr) + ']'
else
msTraceStr := msTraceStr + crlf +
'tag[$' + IntToHex(tag, 4) + ']: '+
TagStr + dExifDelim +
' [size: ' + IntToStr(ByteCount) + ']' +
' [raw: ' + MakeHex(RawStr) + ']' +
' [start: '+ IntToStr(ValuePtr) + ']' +
fstr2;
end else
begin
if not rawDefered then
msTraceStr := msTraceStr + crlf +
tagStr + dExifDelim + fstr2
else
msTraceStr := msTraceStr +
fstr2 + // has cr/lf as first element
crlf + TagStr + dExifDelim + fstr;
end;
end;
if (BuildList in [GenList, GenAll]) and (tagID > 0) then
begin
try
NewEntry := TagTbl[tagID];
if rawdefered then
NewEntry.Data := fStr
else
NewEntry.Data := fStr2;
NewEntry.Raw := rawStr;
NewEntry.TType := tagFormat;
NewEntry.Count := tagComponents;
NewEntry.TID := CustomEXIF; // = 1 --> Manufacturer-specific
AddTagToArray(NewEntry);
except
// if we're here: unknown tag.
// item is recorded in trace string
end;
end;
end;
except
on E: Exception do
TImgData(FParent).SetError('Error detected: ' + E.Message);
end;
SetDataBuff(TImgData(FParent).DataBuff);
end;
procedure TImageInfo.AddMSTag(ATagName: String; ARawStr: ansistring; AType: word);
var
newEntry: TTagEntry;
begin
if BuildList in [GenList,GenAll] then
begin
try
InitTagEntry(newEntry);
newEntry.Name := ATagName;
newEntry.Desc := InsertSpaces(ATagName);
newEntry.Data := ARawStr;
newEntry.Raw := ARawStr;
newEntry.Size := Length(ARawStr);
NewEntry.TType:= AType;
NewEntry.Count := 1;
newEntry.ParentID := 0;
newEntry.TID := CustomEXIF; // = 1 --> manufacturer-specific
AddTagToArray(newEntry);
except
// if we're here: unknown tag.
// item is recorded in trace string
end;
end;
end;
{ Creates a thumbnail image from the main image loaded. The size of the thumbnail
(width or height whichever is longer) is specified as AThumbnailSize.
The current thumbnail image is replaced by the new one, or, if the image did
not have a thumbnail image so far it is added to the image. }
procedure TImageInfo.CreateThumbnail(AThumbnailSize: Integer = DEFAULT_THUMBNAIL_SIZE);
var
srcStream, destStream: TMemoryStream;
begin
srcStream := TMemoryStream.Create;
destStream := TMemoryStream.Create;
try
srcStream.LoadFromFile(TImgData(FParent).FileName);
JpegScaleImage(srcStream, destStream, AThumbnailSize);
destStream.Position := 0;
LoadThumbnailFromStream(destStream);
finally
destStream.Free;
srcStream.Free;
end;
end;
function TImageInfo.HasThumbnail: boolean;
begin
Result := Length(FThumbnailBuffer) > 0;
end;
(*
procedure TImageInfo.ProcessThumbnail;
var
start: Integer;
begin
exit;
FiThumbCount := 0;
start := FThumbStart + 9;
ProcessExifDir(start, 9, FThumbLength - 12, ttThumb, 'Thumbnail', 1);
ExtractThumbnail;
end;
procedure TImageInfo.ExtractThumbnail;
begin
if FThumbnailStartOffset > 0 then begin
SetLength(FThumbnailBuffer, FThumbnailSize);
Move(TImgData(FParent).ExifSegment^.Data[FThumbnailStartOffset + 9], FThumbnailBuffer[0], FThumbnailSize);
end else
FThumbnailBuffer := nil;
end;
*)
procedure TImageInfo.LoadThumbnailFromStream(AStream: TStream);
var
n: Integer;
w, h: Integer;
begin
RemoveThumbnail;
// Check whether the image is a jpeg, and extract size of the thrumbnail image
if not JPEGImageSize(AStream, w, h) then
exit;
// Write the image from the stream into the thumbnail buffer
n := AStream.Size;
if n > 65000 then // limit probably still too high, thumbnail must fit into a 64k segment along with all other tags...
raise Exception.Create('Thumbnail too large.');
SetLength(FThumbnailBuffer, n);
if AStream.Read(FThumbnailBuffer[0], n) < n then
raise Exception.Create('Could not read thumbnail image.');
// Make sure that the IFD1 tags for the thumbnail are correct
SetThumbTagValue('Compression', 6); // 6 = JPEG - this was checked above.
SetThumbTagValue('ImageWidth', w);
SetThumbTagValue('ImageLength', h);
SetThumbTagValue('JPEGInterchangeFormat', 0); // to be replaced by the offset to the thumbnail
SetThumbTagValue('JPEGInterchangeFormatLength', n);
end;
procedure TImageInfo.RemoveThumbnail;
var
newSize: integer;
begin
SetLength(FThumbnailBuffer, 0);
fiThumbCount := 0;
if FThumbStart > 1 then begin
newSize := FThumbStart - 6;
with TImgData(FParent) do
begin
SetLength(ExifSegment^.Data, newSize);
ExifSegment^.Size := newSize;
// size calculations should really be moved to save routine
ExifSegment^.data[1] := ansichar(newSize div 256);
ExifSegment^.data[2] := ansichar(newSize mod 256);
end;
FThumbStart := 0;
end;
end;
procedure TImageInfo.SaveThumbnailToStream(AStream: TStream);
var
n: Int64;
begin
if HasThumbnail then
begin
n := Length(FThumbnailBuffer);
if AStream.Write(FThumbnailBuffer[0], n) <> n then
raise Exception.Create('Cannot write Thumbnail image to stream.');
end;
end;
function TImageInfo.ToLongString(ALabelWidth: Integer = 15): String;
var
tmpStr: String;
FileDateTime: String;
L: TStringList;
W: Integer;
lParent: TImgData;
begin
lParent := TImgData(FParent);
W := ALabelWidth;
L := TStringList.Create;
try
(*
if parent.ExifSegment = nil then
Result := ''
else
*)
if lParent.ErrStr <> NO_ERROR then
begin
L.Add(Format('File Name: %s', [ExtractFileName(lParent.Filename)]));
L.Add(Format('Exif Error: %s', [lParent.ErrStr]));
Result := L.Text;
end else
begin
FileDateTime := FormatDateTime(lParent.DateTimeFormat, lParent.FileDateTime);
L.Add(Format('%-*s %s', [w, 'File name:', ExtractFileName(lParent.Filename)]));
L.Add(Format('%-*s %dkB', [w, 'File size:', lParent.FileSize div 1024]));
L.Add(Format('%-*s %s', [w, 'File date:', FileDateTime]));
L.Add(Format('%-*s %s', [w, 'Photo date:', FormatDateTime(lParent.DateTimeFormat, GetImgDateTime)]));
L.Add(Format('%-*s %s (%s)', [w, 'Make (model):', CameraMake, CameraModel]));
L.Add(Format('%-*s %d x %d', [w, 'Dimensions:', Width, Height]));
if BuildList in [GenString,GenAll] then
begin
tmpStr := TagValueAsString['ExposureTime'];
if tmpStr <> '' then
L.Add(Format('%-*s %s', [w, 'Exposure time:', tmpStr]))
else
begin
tmpStr := TagValueAsstring['ShutterSpeedValue'];
if tmpStr <> '' then
L.Add(Format('%-*s %s', [w, 'Exposure time:', tmpStr]));
end;
tmpStr := TagValueAsString['FocalLength'];
if tmpStr <> '' then
L.Add(Format('%-*s %s', [w, 'Focal length:', tmpStr]));
tmpStr := TagValueAsString['FocalLengthIn35mm'];
if tmpStr <> '' then
L.Add(Format('%-*s %s', [w, 'Focal length (35mm):', tmpStr]));
tmpStr := TagValueAsString['FNumber'];
if tmpStr <> '' then
L.Add(Format('%-*s %s', [w, 'F number', tmpStr]));
tmpStr := TagValueAsString['ISOSpeedRatings'];
if tmpStr <> '' then
L.Add(Format('%-*s %s', [w, 'ISO:', tmpStr]));
end;
L.Add(Format('%-*s %s', [w, 'Flash fired:', siif(odd(FlashUsed),'Yes','No')]));
Result := L.Text;
end;
finally
L.Free;
end;
end;
function TImageInfo.ToShortString: String;
var
lParent: TImgData;
begin
lParent := TImgData(FParent);
if lParent.ErrStr <> NO_ERROR then
Result := ExtractFileName(lParent.Filename) + ' Exif Error: ' + lParent.ErrStr
else
Result := ExtractFileName(lParent.Filename) + ' ' +
IntToStr(lParent.FileSize div 1024) + 'kB '+
FormatDateTime(lParent.DateTimeFormat, GetImgDateTime) + ' ' +
IntToStr(Width) + 'w ' + IntToStr(Height) + 'h '+
siif(odd(FlashUsed),' Flash', '');
end;
procedure TImageInfo.AdjExifSize(AHeight, AWidth: Integer);
begin
TagValue['ImageWidth'] := AWidth;
TagValue['ImageLength'] := AHeight;
end;
procedure TImageInfo.InternalGetBinaryTagValue(const ATag: TTagEntry;
var ABuffer: ansistring);
begin
ABuffer := '';
if ATag.Tag = 0 then
exit;
if ATag.TType = FMT_BINARY then begin
SetLength(ABuffer, Length(ATag.Raw));
Move(ATag.Raw[1], ABuffer[1], Length(ATag.Raw));
end;
end;
function TImageInfo.InternalGetTagValue(const ATag: TTagEntry): Variant;
var
s: String;
r: TExifRational;
i: Integer;
intValue: Integer;
floatValue: Extended;
begin
Result := Null;
if ATag.Tag = 0 then
exit;
// Handle strings
case ATag.TType of
FMT_STRING:
begin
{$IFDEF FPC}
{$IFDEF FPC3+}
s := ATag.Raw;
{$ELSE}
s := AnsiToUTF8(ATag.Raw);
{$ENDIF}
{$ELSE}
s := ATag.Raw;
{$ENDIF}
while (s <> '') and (s[Length(s)] = #0) do
Delete(s, Length(s), 1);
Result := s;
exit;
end;
FMT_BINARY:
begin
Result := BinaryTagToVar(ATag);
exit;
end;
end;
// Handle numeric data. Be aware that they may be arrays
if ATag.Count = 1 then
// Result := NumericTagToInt(@ATag.Raw[1], ATag.TType)
Result := NumericTagToVar(@ATag.Raw[1], ATag.TType)
else begin
case ATag.TType of
FMT_BYTE, FMT_USHORT, FMT_ULONG:
Result := VarArrayCreate([0, ATag.Count-1], varInteger);
FMT_URATIONAL, FMT_SRATIONAL:
Result := VarArrayCreate([0, ATag.Count-1], varDouble);
end;
for i:=0 to ATag.Count-1 do
Result[i] := NumericTagToVar(@ATag.Raw[1 + BYTES_PER_FORMAT[ATag.TType]*i], ATag.TType);
end;
// Correction for some special cases
case ATag.Tag of
TAG_SHUTTERSPEED:
// Is stored as -log2 of exposure time
Result := power(2.0, -Result);
end;
end;
function TImageInfo.BinaryTagToStr(const ATag: TTagEntry): String;
begin
Result := ATag.Raw;
end;
function TImageInfo.BinaryTagToVar(const ATag: TTagEntry): Variant;
var
s: String;
begin
case ATag.Tag of
TAG_EXIFVERSION,
TAG_FLASHPIXVERSION,
TAG_INTEROPVERSION:
begin
SetLength(s, Length(ATag.Raw));
Move(ATag.Raw[1], s[1], Length(s));
Result := s;
end;
TAG_USERCOMMENT:
begin
Result := GetExifComment;
end;
else
Result := '<binary>';
end;
end;
{ ABuffer points into the raw buffer of a tag. The number pointed to will be
converted to a numeric value; its type depends on ATagType. }
function TImageInfo.NumericTagToVar(ABuffer: Pointer; ATagType: Integer): Variant;
var
r: TExifRational;
begin
case ATagType of
FMT_BYTE:
Result := PByte(ABuffer)^;
FMT_USHORT:
if MotorolaOrder then
Result := BEToN(PWord(ABuffer)^) else
Result := LEToN(PWord(ABuffer)^);
FMT_ULONG:
if MotorolaOrder then
Result := BEToN(PDWord(ABuffer)^) else
Result := LEToN(PDWord(ABuffer)^);
FMT_URATIONAL,
FMT_SRATIONAL:
begin
r := PExifRational(ABuffer)^;
if MotorolaOrder then begin
r.Numerator := LongInt(BEToN(DWord(r.Numerator))); // Type cast needed for D7
r.Denominator := LongInt(BEToN(DWord(r.Denominator)));
end else begin
r.Numerator := LongInt(LEToN(DWord(r.Numerator)));
r.Denominator := LongInt(LEtoN(DWord(r.Denominator)));
end;
if ATagType = FMT_SRATIONAL then begin
r.Numerator := LongInt(r.Numerator);
r.Denominator := LongInt(r.Denominator);
end;
Result := Extended(r.Numerator / r.Denominator);
end;
{
FMT_BINARY:
if ATag.Size = 1 then
Result := PByte(@ATag.Raw[1])^
else
Result := '<binary>';
}
else
raise Exception.CreateFmt('NumericTagToVar does not handle Tag type %d', [ord(ATagType)]);
end;
end;
{ Central routine for writing data to a tag.
ATagName ........... Name of the tag
AValue ............. Value to be written to the tag if the tag is not binary
ABinaryData ........ Data to be written to the tag if it is binary
ABinaryDataCount ... Number of bytes to be written to a binary tag.
ATagTypes .......... Determines in which list the tag definition is found
(Exif&Thumb, or GPS), and which list will get the new tag
(Exif&GPS, or thumb }
procedure TImageInfo.InternalSetTagValue(const ATagName: String; AValue: Variant;
ATagTypes: TTagTypes; ABinaryData: Pointer = nil; ABinaryDataCount: Word = 0);
const
IGNORE_PARENT = $FFFF;
var
P: PTagEntry;
tagDef: PTagEntry;
tagID: Word;
parentID: Word;
strValue: String;
i: Integer;
begin
// Find the tag's ID from the lists of tag definitions.
// Note: Normal ("Exif") and thumbnail tags share the same list, gps tags
// are separate.
if (ATagTypes * [ttExif, ttThumb] <> []) then
tagDef := FindExifTagDefByName(ATagName) else
tagDef := nil;
if (tagDef = nil) and (ttGps in ATagTypes) then
tagDef := FindGpsTagDefByName(ATagName);
if tagDef = nil then
raise Exception.CreateFmt('Tag "%s" not found.', [ATagName]);
tagID := tagDef.Tag;
// Delete this tag if the provided value is varNull or varEmpty
if tagDef.TType = FMT_BINARY then begin
if ABinaryData = nil then begin
RemoveTag(ATagTypes, tagID, tagDef^.ParentID);
exit;
end;
end else begin
if VarIsNull(AValue) or VarIsEmpty(AValue) then begin
RemoveTag(ATagTypes, tagID, tagDef^.ParentID);
exit;
end;
end;
// Find the pointer to the tag
P := FindTagPtr(tagDef^, (ttThumb in ATagTypes));
// P := GetTagPtr(ATagTypes, tagID, false, IGNORE_PARENT);
if P = nil then begin
// The tag does not yet exist --> create a new one.
// BUT: The TagTable does not show the ParentIDs...
// Until somebody updates this we put the new tag into the root directory
// (IFD0). Since this may not be allowed there's a risk that the EXIF in the
// modified file cannot be read correctly...
{
if(ttGps in ATagTypes) then
parentID := TAG_GPS_OFFSET
else
parentID := 0;
}
P := CreateTagPtr(tagDef^, (ttThumb in ATagTypes), tagDef^.ParentID);
end;
if P = nil then
raise Exception.CreateFmt('Failure to create tag "%s"', [ATagName]);
// Handle string data
if P^.TType = FMT_STRING then begin
strValue := VarToStr(AValue);
{$IFDEF FPC}
P^.Raw := UTF8ToAnsi(strValue) + #0;
{$ELSE}
P^.Raw := AnsiString(strValue) + #0;
{$ENDIF}
p^.Size := Length(p^.Raw);
P^.Data := P^.Raw;
exit;
end;
// Handle binary data
if P^.TType = FMT_BINARY then begin
SetLength(P^.Raw, ABinaryDataCount);
Move(ABinaryData^, P^.Raw[1], ABinaryDataCount);
P^.Size := ABinaryDataCount;
P^.Data := '<binary>';
exit;
end;
// NOTE: Since hardware-specific data are not yet decoded the element Raw
// is still in the endianness of the source!
// Handle some special cases
case tagID of
TAG_SHUTTERSPEED:
begin
strValue := VarToStr(AValue);
if pos('/', strValue) > 0 then
AValue := CvtRational(ansistring(strValue));
// The shutter speed value is stored as -log2 of exposure time
AValue := -log2(AValue);
end;
TAG_EXPOSURETIME:
begin
strValue := VarToStr(AValue);
if pos('/', strValue) > 0 then
AValue := CvtRational(ansistring(strValue));
end;
end;
p^.Raw := '';
p^.Data := '';
p^.Size := 0;
if VarIsArray(AValue) then
for i:=VarArrayLowBound(AValue, 1) to VarArrayHighBound(AValue, 1) do
VarToNumericTag(AValue[i], p)
else
VarToNumericTag(AValue, p);
end;
procedure TImageInfo.VarToNumericTag(AValue:variant; ATag: PTagEntry);
var
intValue: Integer;
fracvalue: TExifRational;
len: Integer;
s: String;
w: Word;
dw: DWord;
ok: Boolean;
begin
if VarIsArray(AValue) then
raise Exception.Create('No variant arrays allowed in VarToTag');
// fractional data
if (ATag^.TType in [FMT_URATIONAL, FMT_SRATIONAL]) then
begin
fracvalue := DoubleToRational(AValue);
if MotorolaOrder then begin
fracvalue.Numerator := LongInt(NToBE(DWord(fracValue.Numerator))); // Type-cast needed for D7
fracValue.Denominator := LongInt(NToBE(DWord(fracValue.Denominator)));
end else begin
fracValue.Numerator := LongInt(NtoLE(DWord(fracValue.Numerator)));
fracValue.Denominator := LongInt(NtoLE(DWord(fracValue.Denominator)));
end;
len := Length(ATag^.Raw);
SetLength(ATag^.Raw, len + 8);
Move(fracValue, ATag^.Raw[len + 1], 8);
ATag^.Size := Length(ATag^.Raw);
s := FormatNumber(@ATag^.Raw[1], Length(ATag^.Raw), ATag^.TType, ATag^.FormatS, ATag^.Code);
{
if Assigned(ATag.Callback) and Parent.Decode then
s := ATag.Callback(s);
}
ATag^.Data := s; //siif(len = 0, s, ATag^.Data + dExifDataSep + s);
exit;
end;
// integer data
if VarIsType(AValue, vtInteger) then begin
case ATag^.TType of
FMT_BYTE : ok := (AValue >= 0) and (AValue <= 255);
FMT_USHORT : ok := (AValue >= 0) and (AValue <= Word($FFFF));
FMT_ULONG : ok := (AValue >= 0) and (AValue <= DWord($FFFFFFFF));
FMT_SBYTE : ok := (AValue >= -128) and (AValue <= 127);
FMT_SSHORT : ok := (AValue >= -32768) and (AValue <= 32767);
FMT_SLONG : ok := (AValue >= -2147483647) and (AValue <= 2147483647);
{ NOTE: D7 does not run with the correct lower limit -2147483648 }
end;
if not ok then
raise Exception.CreateFmt('Tag "%s": Value "%s" is out of range.', [ATag^.Name, VarToStr(AValue)]);
end;
if not TryStrToInt(VarToStr(AValue), intValue) then begin
intValue := GetTagCode(ATag^, VarToStr(AValue));
if (intValue = -1) then
raise Exception.CreateFmt('Lookup value "%s" of tag "%s" not found', [VarToStr(AValue), ATag^.Name]);
end;
len := Length(ATag^.Raw);
SetLength(ATag^.Raw, len + BYTES_PER_FORMAT[ATag^.TType]);
case ATag^.TType of
FMT_BYTE:
Move(intValue, ATag^.Raw[1+len], 1);
FMT_USHORT:
begin
if MotorolaOrder then w := NtoBE(word(intValue)) else w := NtoLE(word(intvalue));
Move(w, ATag^.Raw[1+len], 2);
end;
FMT_ULONG:
begin
if MotorolaOrder then
dw := NtoBE(DWord(intValue)) else
dw := NtoLE(DWord(intValue));
Move(dw, ATag^.Raw[1+len], 4);
end;
else
raise Exception.Create('Unhandled data format in VarToNumericTag');
end;
ATag^.Size := Length(ATag^.Raw);
s := FormatNumber(@ATag^.Raw[1], Length(ATag^.Raw), ATag^.TType, ATag^.FormatS, ATag^.Code);
ATag^.Data := siif(len = 0, s, ATag^.Data + dExifDataSep + s);
end;
function TImageInfo.GetTagByID(ATagID: Word): TTagEntry;
var
i: Integer;
begin
for i:= 0 to fiTagCount - 1 do
if (fiTagArray[i].Tag = ATagID) and (fiTagArray[i].TID = GenericEXIF) then
begin
Result := fiTagArray[i];
exit;
end;
Result := EmptyEntry;
end;
procedure TImageInfo.SetTagByID(ATagID: Word; const AValue: TTagEntry);
var
i: Integer;
P: PTagEntry;
begin
for i:=0 to fiTagCount-1 do
if (fITagArray[i].Tag = ATagID) and (fiTagArray[i].TID = GenericEXIF) then
begin
fITagArray[i] := AValue;
exit;
end;
// If not found: add it as a new tag to the array
P := FindExifTagDefByID(ATagID);
if P = nil then begin
P := FindGpsTagDefByID(ATagID);
if P = nil then
raise Exception.CreateFmt('TagID $%.4x unknown.', [ATagID]);
end;
AddTagToArray(AValue);
end;
function TImageInfo.GetTagByIndex(AIndex: Integer): TTagEntry;
begin
Result := fiTagArray[AIndex];
end;
procedure TImageInfo.SetTagByIndex(AIndex: Integer; const AValue: TTagEntry);
begin
FITagArray[AIndex] := AValue;
end;
function TImageInfo.GetTagByName(ATagName: String): TTagEntry;
var
i: integer;
begin
i := LookupTagIndex(ATagName);
if i >= 0 then
Result := fITagArray[i]
else
Result := EmptyEntry;
end;
procedure TImageInfo.SetTagByName(ATagName: String; const AValue: TTagEntry);
var
i: integer;
P: PTagEntry;
begin
i := LookupTagIndex(ATagName);
if i >= 0 then
fITagArray[i] := AValue
else
begin
// If not found: add it as a new tag to the array
P := FindExifTagDefByName(ATagName);
if P = nil then begin
P := FindGpsTagDefByName(ATagName);
if P = nil then
raise Exception.Create('Tag "' + ATagName + '" unknown.');
end;
AddTagToArray(AValue);
end;
end;
function TImageInfo.GetTagValue(ATagName: String): Variant;
var
tag: TTagEntry;
begin
Result := Null;
tag := GetTagByName(ATagName);
if (tag.Name = '') or (tag.Name = 'Unknown') then
exit;
Result := InternalGetTagValue(tag);
end;
procedure TImageInfo.SetTagValue(ATagName: String; AValue: Variant);
begin
InternalSetTagValue(ATagName, AValue, [ttExif, ttGps]);
end;
function TImageInfo.GetTagValueAsString(ATagName: String): String;
var
tag: TTagEntry;
begin
Result := '';
tag := GetTagByName(ATagName);
if (tag.Name = '') or (tag.Name = 'Unknown') then
exit;
Result := InternalGetTagValueAsString(tag);
end;
function TImageInfo.InternalGetTagValueAsString(const ATag: TTagEntry): String;
var
s: String;
begin
if ATag.TType = FMT_STRING then
begin
{$IFDEF FPC}
{$IFDEF FPC3+}
s := ATag.Raw;
{$ELSE}
s := AnsiToUTF8(ATag.Raw);
{$ENDIF}
{$ELSE}
s := ATag.Raw;
{$ENDIF}
while (s <> '') and ((s[Length(s)] = #0) or (s[Length(s)] = ' ')) do
Delete(s, Length(s), 1);
Result := s;
end else
if ATag.TType = FMT_BINARY then
begin
if (ATag.Size=1) then begin
Result := FormatNumber(@ATag.Raw[1], Length(ATag.Raw), ATag.TType, ATag.FormatS, ATag.Code);
if Assigned(ATag.Callback) and Decode then
Result := ATag.Callback(Result);
end else
if ATag.Name = 'ExifVersion' then
Result := GetVersion(ATag)
else if ATag.Name = 'FlashPixVersion' then
Result := GetVersion(ATag)
else if ATag.Name = 'InteroperabilityVersion' then
Result := GetVersion(ATag)
else if ATag.Name = 'UserComment' then
Result := GetExifComment
else begin
Result := BinaryTagToStr(ATag);
if Assigned(ATag.Callback) and Decode then
Result := ATag.Callback(Result);
end;
end else
begin
Result := FormatNumber(@ATag.Raw[1], Length(ATag.Raw), ATag.TType, ATag.FormatS, ATag.Code);
if Assigned(ATag.Callback) and Decode then
Result := ATag.Callback(Result)
end;
end;
procedure TImageInfo.SetTagValueAsString(ATagName: String; AValue: String);
var
v: Variant;
begin
v := AValue;
SetTagValue(ATagName, v);
end;
function TImageInfo.GetThumbTagByID(ATagID: Word): TTagEntry;
var
i: Integer;
begin
for i:= 0 to fiThumbCount - 1 do
if (fiThumbArray[i].Tag = ATagID) then
begin
Result := fiThumbArray[i];
exit;
end;
Result := EmptyEntry;
end;
procedure TImageInfo.SetThumbTagByID(ATagID: Word; const AValue: TTagEntry);
var
i: Integer;
P: PTagEntry;
begin
for i:=0 to fiThumbCount-1 do
if fIThumbArray[i].Tag = ATagID then begin
fIThumbArray[i] := AValue;
exit;
end;
// If not found: add it as a new tag to the array
P := FindExifTagDefByID(ATagID); // Thumb tags are stored in Exif table
if P = nil then
raise Exception.CreateFmt('TagID $%.4x unknown.', [ATagID]);
AddTagToThumbArray(AValue);
end;
function TImageInfo.GetThumbTagByIndex(AIndex: Integer): TTagEntry;
begin
Result := fiThumbArray[AIndex];
end;
procedure TImageInfo.SetThumbTagByIndex(AIndex: Integer; const AValue: TTagEntry);
begin
fiThumbArray[AIndex] := AValue;
end;
function TImageInfo.GetThumbTagByName(ATagName: String): TTagEntry;
var
i: integer;
begin
ATagName := Uppercase(ATagName);
for i:= 0 to fiThumbCount - 1 do
if Uppercase(fiThumbArray[i].Name) = ATagName then begin
Result := fiThumbArray[i];
exit;
end;
Result := EmptyEntry;
end;
procedure TImageInfo.SetThumbTagByName(ATagName: String; const AValue: TTagEntry);
var
i: Integer;
P: PTagEntry;
begin
ATagName := Uppercase(ATagName);
for i:=0 to fiThumbCount-1 do
if Uppercase(fIThumbArray[i].Name) = ATagName then begin
fIThumbArray[i] := AValue;
exit;
end;
{
// If not found: add it as a new tag to the array
P := FindExifTagDefByName(ATagName); // Thumb tags are stored in Exif table
if P = nil then
raise Exception.Create('Tag "' + ATagName + '" unknown.');
AddTagToThumbArray(AValue);
}
end;
function TImageInfo.GetThumbTagValue(ATagName: String): Variant;
var
tag: TTagEntry;
begin
tag := GetThumbTagByName(ATagName);
Result := InternalGetTagValue(tag);
end;
procedure TImageInfo.SetThumbTagValue(ATagName: String; AValue: Variant);
begin
InternalSetTagValue(ATagName, AValue, [ttThumb]);
end;
function TImageInfo.GetThumbTagValueAsString(ATagName: String): String;
var
tag: TTagEntry;
begin
Result := '';
tag := GetThumbTagByName(ATagName);
if (tag.Name = '') or (tag.Name = 'Unknown') then
exit;
Result := InternalGetTagValueAsString(tag);
end;
procedure TImageInfo.SetThumbTagValueAsString(ATagName: String; AValue: String);
var
v: Variant;
begin
v := AValue;
SetThumbTagValue(ATagName, v);
end;
function TImageInfo.GetWidth: Integer;
var
v: Variant;
begin
Result := 0;
v := TagValue['ImageWidth'];
if VarIsNull(v) then begin
v := TagValue['ExifImageWidth'];
if VarIsNull(v) then
exit;
end;
Result := v;
end;
procedure TImageInfo.SetWidth(AValue: Integer);
begin
TagValue['ImageWidth'] := AValue;
end;
function TImageInfo.GetHeight: Integer;
var
v: Variant;
begin
Result := 0;
v := TagValue['ImageLength'];
if VarIsNull(v) then begin
v := TagValue['ExifImageLength'];
if VarIsNull(v) then
exit;
end;
Result := v;
end;
procedure TImageInfo.SetHeight(AValue: Integer);
begin
TagValue['ImageLength'] := AValue;
end;
procedure TImageInfo.RemoveTag(ATagTypes: TTagTypes; ATagID: Word; AParentID: Word=0);
var
i: Integer;
begin
i := 0;
if ttThumb in ATagTypes then
begin
while i < fiThumbCount do
begin
if (fiThumbArray[i].Tag = ATagID) and (fiThumbArray[i].ParentID = AParentID) then
begin
while (i < fiThumbCount-1) do begin
fiThumbArray[i] := fiThumbArray[i+1];
inc(i);
end;
dec(fiThumbCount);
break;
end else
inc(i);
end;
end else
begin
while i < fiTagCount do
begin
if (fiTagArray[i].Tag = ATagID) and (fiTagArray[i].ParentID = AParentID) then
begin
while (i < fiTagCount-1) do begin
fiTagArray[i] := fiTagArray[i+1];
inc(i);
end;
dec(fiTagCount);
break;
end else
inc(i);
end;
end;
end;
(*
procedure TImageInfo.RemoveTag(ATagTypes: TTagTypes; ATagID: Word; AParentID: Word=0);
var
i, j: integer;
begin
j := 0;
if ttThumb in ATagTypes then begin
for i := 0 to fiThumbCount-1 do begin
if (j <> 0) then
fiThumbArray[i-j] := fiThumbArray[i];
if (fiThumbArray[i].ParentID = AParentID) and (fiThumbArray[i].Tag = ATagID) then
inc(j);
end;
if (j <> 0) and (fiThumbCount > 0) then
dec(fiThumbCount);
end else
begin
for i := 0 to fiTagCount-1 do begin
if (j <> 0) then
fiTagArray[i-j] := fiTagArray[i];
if (fiTagArray[i].ParentID = AParentID) and (fiTagArray[i].Tag = ATagID) then
inc(j);
end;
if (j <> 0) and (fiTagCount > 0) then
dec(fiTagCount);
end;
end;
*)
function TImageInfo.CreateTagPtr(const ATagDef: TTagEntry; IsThumbTag: Boolean;
AParentID: Word = 0): PTagEntry;
var
pTag: PTagEntry;
tag: TTagEntry;
idx: Integer;
begin
tag := ATagDef;
if tag.Size > 0 then
tag.Raw := StringOfChar(#0, tag.Size);
if IsThumbTag then
begin
tag.ParentID := 1;
idx := AddTagToThumbArray(tag);
Result := @fiThumbArray[idx];
end else
begin
// Create the parent tag if it does not exist, yet.
if (AParentID <> 0) and (GetTagByID(AParentID).Tag = 0) then begin
pTag := FindExifTagDefByID(AParentID);
if pTag = nil then
raise Exception.CreateFmt('Definition for tag $%.4x not found.', [AParentID]);
pTag^.ParentID := 0;
pTag^.Raw := StringOfChar(#0, pTag^.Size);
AddTagToArray(pTag^);
end;
tag.ParentID := AParentID;
idx := AddTagToArray(tag);
Result := @fiTagArray[idx];
end;
end;
function TImageInfo.FindTagPtr(const ATagDef: TTagEntry; IsThumbTag: Boolean): PTagEntry;
var
i: Integer;
begin
if IsThumbTag then
begin
for i:=0 to fiThumbCount-1 do
if (fiThumbArray[i].Tag = ATagDef.Tag) and (fiThumbArray[i].Name = ATagDef.Name) then
begin
Result := @fiThumbArray[i];
exit;
end;
end else
begin
for i:=0 to fiTagCount-1 do
if (fiTagArray[i].Tag = ATagDef.Tag) and (fiTagArray[i].Name = ATagDef.Name) then
begin
Result := @fiTagArray[i];
exit;
end;
end;
Result := nil;
end;
(*
function TImageInfo.GetTagPtr(ATagTypes: TTagTypes; ATagID: word;
AForceCreate: Boolean=false; AParentID:word=0; ATagType: word=65535): PTagEntry;
var
i, j: integer;
tag: TTagEntry;
begin
Result := nil;
if (ttThumb in ATagTypes) then begin
if AParentID = $FFFF then // $FFFF: ignore parent
for i:= 0 to fiThumbCount-1 do
if (fiThumbArray[i].Tag = ATagID) then begin
Result := @fiThumbArray[i];
exit;
end;
for i := 0 to fiThumbCount-1 do
if (fiThumbArray[i].ParentID = AParentID) and (fiThumbArray[i].Tag = ATagID) then
begin
Result := @fiThumbArray[i];
exit;
end;
end else
begin
if AParentID = $FFFF then // $FFFF: ignore parent
for i := 0 to fiTagCount - 1 do
if (fiTagArray[i].Tag = ATagID) then begin
Result := @fiTagArray[i];
exit;
end;
for i := 0 to fiTagCount-1 do
if (fiTagArray[i].ParentID = AParentID) and (fiTagArray[i].Tag = ATagID) then
begin
Result := @fiTagArray[i];
exit;
end;
end;
if AForceCreate then begin
tag := FindExifTagDefByID(ATagID)^;
if ATagType <> 65535 then
tag.TType := ATagType;
tag.Id := 0;
if tag.Size > 0 then
tag.Raw := StringOfChar(#0, tag.Size);
if (ttThumb in ATagTypes) then begin
tag.ParentID := 1;
i := AddTagToThumbArray(tag);
Result := @fiThumbArray[i];
end;
if ([ttExif, ttGps] * ATagTypes <> []) then begin
tag.parentID := AParentID;
i := AddTagToArray(tag);
Result := @fiTagArray[i];
end;
end;
end;
*)
function TImageInfo.GetArtist: String;
begin
Result := GetTagValueAsString('Artist');
end;
procedure TImageInfo.SetArtist(v: String);
begin
SetTagValue('Artist', v);
end;
function TImageInfo.GetUserComment(const ATag: TTagEntry): String;
var
buf: ansistring;
w: widestring;
a: ansistring;
n: Integer;
begin
Result := '';
InternalGetBinaryTagValue(ATag, buf);
if buf = '' then
exit;
if pos('UNICODE', buf) = 1 then begin
SetLength(w, (Length(buf) - 8) div SizeOf(WideChar));
Move(buf[9], w[1], Length(w) * Sizeof(WideChar));
{$IFDEF FPC}
Result := UTF8Encode(w);
{$ELSE}
Result := w;
{$ENDIF}
end else
if pos('ASCII', buf) = 1 then begin
a := Copy(buf, 9, MaxInt);
while (a <> '') and ((a[Length(a)] = #0) or (a[Length(a)] = ' ')) do
Delete(a, Length(a), 1);
Result := a;
end else
if pos(#0#0#0#0#0#0#0#0, buf) = 1 then begin
a := Copy(buf, 9, MaxInt);
while (a <> '') and ((a[Length(a)] = #0) or (a[Length(a)] = ' ')) do
Delete(a, Length(a), 1);
{$IFDEF FPC}
{$IFDEF FPC3+}
Result := WinCPToUTF8(a);
{$ELSE}
Result := SysToUTF8(a);
{$ENDIF}
{$ELSE}
Result := a;
{$ENDIF}
end else
if Pos('JIS', buf) = 1 then
raise Exception.Create('JIS-encoded user comment is not supported.');
end;
function TImageInfo.GetExifComment: String;
var
tag: TTagEntry;
begin
tag := GetTagByName('UserComment');
if tag.Tag <> 0 then
Result := GetUserComment(tag)
else
Result := '';
end;
(*
function TImageInfo.GetExifComment: String;
var
p : PTagEntry;
w : WideString;
n: Integer;
sa: AnsiString;
begin
Result := '';
w := '';
p := GetTagPtr([ttExif], TAG_EXIF_OFFSET);
if (p = nil) then
exit;
p := GetTagPtr([ttExif], TAG_USERCOMMENT, false, TAG_EXIF_OFFSET);
if (p = nil) or (Length(p^.Raw) <= 10) then
exit;
if Pos('UNICODE', p^.Raw) = 1 then begin
SetLength(w, (Length(p^.Raw) - 8) div SizeOf(WideChar));
Move(p^.Raw[9], w[1], Length(w) * SizeOf(WideChar));
{$IFDEF FPC}
Result := UTF8Encode(w);
{$ELSE}
Result := w;
{$ENDIF}
end else
if Pos('ASCII', p^.Raw) = 1 then begin
SetLength(Result, Length(p^.Raw)-9);
sa := p^.Raw;
Delete(sa, 1, 8);
Result := sa;
end else
if Pos(#0#0#0#0#0#0#0#0, p^.Raw) = 1 then begin
SetLength(sa, Length(p^.Raw) - 9);
Move(p^.raw[9], sa[1], Length(sa));
{$IFDEF FPC}
{$IFNDEF FPC3+}
Result := SysToUTF8(sa);
{$ELSE}
Result := WinCPToUTF8(sa);
{$ENDIF}
{$ELSE}
Result := sa;
{$ENDIF}
end else
if Pos('JIS', p^.Raw) = 1 then
raise Exception.Create('JIS-encoded user comment is not supported.');
end;
*)
procedure TImageInfo.SetExifComment(AValue: String);
var
p: PTagEntry;
i: integer;
w: WideString;
a: AnsiString;
u: Boolean;
buf: array of byte;
len: Integer;
begin
if AValue = '' then
SetLength(buf, 0)
else
begin
u := false;
for i:=1 to Length(AValue) do
if byte(AValue[i]) > 127 then begin
u := true;
break;
end;
if u then begin
{$IFDEF FPC}
w := UTF8Decode(AValue);
{$ELSE}
w := AValue;
{$ENDIF}
SetLength(buf, 8 + Length(w) * SizeOf(WideChar)); // +8 for header
a := 'UNICODE'#0;
Move(a[1], buf[0], 8);
Move(w[1], buf[8], Length(w) * Sizeof(WideChar));
end else
begin
SetLength(buf, 8 + Length(AValue));
a := 'ASCII'#0#0#0;
Move(a[1], buf[0], 8);
a := ansistring(AValue);
Move(a[1], buf[8], Length(a));
end;
end;
InternalSetTagValue('UserComment', NULL, [ttExif, ttGps], @buf[0], Length(buf));
(*
p := GetTagPtr([ttExif], TAG_EXIF_OFFSET, true, 0, FMT_ULONG{, true});
if (v = '') then begin
RemoveTag([ttExif], TAG_USERCOMMENT, TAG_EXIF_OFFSET);
exit;
end;
p := GetTagPtr([ttExif], TAG_USERCOMMENT, true, TAG_EXIF_OFFSET, FMT_BINARY);
u := false;
for i:=1 to Length(v) do
if byte(v[i]) > 127 then begin
u := true;
break;
end;
if u then begin
p^.Raw := 'UNICODE'#0;
// According to docs: no need to add a trailing zero byte
{$IFDEF FPC}
w := UTF8Decode(v);
{$ELSE}
w := v;
{$ENDIF}
SetLength(p^.Raw, Length(w) * SizeOf(WideChar) + 8);
Move(w[1], p^.Raw[9], Length(w) * SizeOf(WideChar));
end else begin
p^.Raw := 'ASCII'#0#0#0;
// According to docs: no need to add a trailing zero byte
a := AnsiString(v);
SetLength(p^.Raw, Length(a) + 8);
i := Length(p^.Raw);
Move(a[1], p^.Raw[9], Length(a));
end;
p^.Size := Length(p^.Raw);
p^.Data := v;
*)
end;
function TImageInfo.GetImageDescription: String;
begin
Result := GetTagValueAsString('ImageDescription');
end;
procedure TImageInfo.SetImageDescription(const AValue: String);
begin
SetTagValue('ImageDescription', AValue);
end;
function TImageInfo.GetCameraMake: String;
begin
Result := GetTagValueAsString('Make');
end;
procedure TImageInfo.SetCameraMake(const AValue: String);
begin
SetTagValue('Make', AValue);
end;
function TImageInfo.GetCameraModel: String;
begin
Result := GetTagValueAsString('Model');
end;
procedure TImageInfo.SetCameraModel(const AValue: String);
begin
SetTagValue('Model', AValue);
end;
function TImageInfo.GetCopyright: String;
begin
Result := GetTagValueAsString('Copyright');
end;
procedure TImageInfo.SetCopyright(const AValue: String);
begin
SetTagValue('Copyright', AValue);
end;
function TImageInfo.GetGPSCoordinate(ATagName: String;
ACoordType: TGPSCoordType): Extended;
var
vDeg, vSgn: Variant;
begin
Result := NaN;
vDeg := GetTagValue(ATagName);
if VarIsNull(vDeg) then
exit;
if not VarIsArray(vDeg) then
exit;
Result := vDeg[0] + vDeg[1]/60 + vDeg[2]/3600;
vSgn := GetTagValue(ATagName + 'Ref');
if VarIsNull(vSgn) then
exit;
case ACoordType of
ctLatitude : if VarToStr(vSgn)[1] in ['S', 's'] then Result := -Result;
ctLongitude : if VarToStr(vSgn)[1] in ['W', 'w'] then Result := -Result;
end;
end;
procedure TImageInfo.SetGPSCoordinate(ATagName: String; const AValue: Extended;
ACoordType: TGPSCoordType);
const
Ref: array[TGPSCoordType] of string[2] = ('NS', 'EW');
var
v: Variant;
degs, mins, secs: double;
val: Extended;
begin
if IsNaN(AValue) then
v := NULL
else begin
val := abs(AValue);
degs := trunc(val);
mins := trunc(frac(val) * 60);
secs := (frac(val) * 60 - mins) * 60;
v := VarArrayOf([degs, mins, secs]);
end;
InternalSetTagValue(ATagName, v, [ttGps]);
if IsNaN(AValue) then
InternalSetTagValue(ATagName + 'Ref', NULL, [ttGps])
else
if AValue > 0 then
InternalSetTagValue(ATagName + 'Ref', Ref[ACoordType, 1], [ttGps])
else
InternalSetTagValue(ATagName + 'Ref', Ref[ACoordType, 2], [ttGps]);
VarClear(v);
end;
function TImageInfo.GetGPSLatitude: Extended;
begin
Result := GetGPSCoordinate('GPSLatitude', ctLatitude);
end;
procedure TImageInfo.SetGPSLatitude(const AValue: Extended);
begin
SetGPSCoordinate('GPSLatitude', AValue, ctLatitude);
end;
function TImageInfo.GetGPSLongitude: Extended;
begin
Result := GetGPSCoordinate('GPSLongitude', ctLongitude);
end;
procedure TImageInfo.SetGPSLongitude(const AValue: Extended);
begin
SetGPSCoordinate('GPSLongitude', AValue, ctLongitude);
end;
{ The version of the supported Exif or FlashPix standard.
All four bytes should be interpreted as ASCII values. The first two bytes
encode the upper part of the standard version, the next two bytes encode the
lower part. For example, the byte sequence 48, 50, 50, 48, is the equivalent
of the ASCII value "0220", and denotes version 2.20.
http://www.awaresystems.be/imaging/tiff/tifftags/privateifd/exif/exifversion.html
http://www.awaresystems.be/imaging/tiff/tifftags/privateifd/exif/flashpixversion.html
}
function TImageInfo.GetVersion(ATag: TTagEntry): String;
var
s: AnsiString;
begin
Result := '';
InternalGetBinaryTagValue(ATag, s);
Result := s;
end;
function TImageInfo.IterateFoundTags(TagId: integer; var RetVal: TTagEntry): boolean;
begin
InitTagEntry(Retval);
while (FIterator < FITagCount) and (FITagArray[FIterator].TID <> TagId) do
inc(FIterator);
if (FIterator < FITagCount) then
begin
RetVal := FITagArray[FIterator];
inc(FIterator);
Result := true;
end
else
Result := false;
end;
procedure TImageInfo.ResetIterator;
begin
FIterator := 0;
end;
function TImageInfo.IterateFoundThumbTags(TagId: integer;
var RetVal: TTagEntry): boolean;
begin
InitTagEntry(RetVal);
while (FThumbIterator < FIThumbCount) and (FITagArray[FThumbIterator].TID <> TagId) do
inc(FThumbIterator);
if (FThumbIterator < FIThumbCount) then
begin
RetVal := FIThumbArray[FThumbIterator];
inc(FThumbIterator);
Result := true;
end
else
Result := false;
end;
procedure TImageInfo.ResetThumbIterator;
begin
FThumbIterator := 0;
end;
function TImageInfo.GetRawFloat(ATagName: String): Double;
var
tiq: TTagEntry;
begin
tiq := GetTagByName(ATagName);
if tiq.Tag = 0 then // EmptyEntry
Result := 0.0
else
Result := GetNumber(@tiq.Raw[1], Length(tiq.Raw), tiq.TType);
end;
function TImageInfo.GetRawInt(ATagName: String): Integer;
var
tiq: TTagEntry;
begin
tiq := GetTagByName(ATagName);
if tiq.Tag = 0 then // EmptyEntry
Result := -1
else
if (tiq.TType = FMT_BINARY) and (tiq.Size = 1) then
Result := byte(tiq.Raw[1])
else
result := round(GetNumber(@tiq.Raw[1], Length(tiq.Raw), tiq.TType));
end;
// Unfortunatly if we're calling this function there isn't
// enough info in the EXIF to calculate the equivalent 35mm
// focal length and it needs to be looked up on a camera
// by camera basis. - next rev - maybe
function TImageInfo.LookupRatio: double;
var
estRatio: double;
upMake, upModel: String;
begin
upMake := Uppercase(copy(CameraMake, 1, 5));
upModel := Uppercase(copy(Cameramodel, 1, 5));
estRatio := 4.5; // ballpark for *my* camera -
Result := estRatio;
end;
procedure TImageInfo.Calc35Equiv;
const
Diag35mm : double = 43.26661531; // sqrt(sqr(24)+sqr(36))
var
tmp: integer;
CCDWidth, CCDHeight, fpu, fl, fl35, ratio: double;
NewE, LookUpE: TTagEntry;
w: Word;
begin
if LookUpTagIndex('FocalLengthin35mmFilm') >= 0 then
exit; // no need to calculate - already have it
CCDWidth := 0.0;
CCDHeight := 0.0;
tmp := GetRawInt('FocalPlaneResolutionUnit');
if (tmp <= 0) then
tmp := GetRawInt('ResolutionUnit');
case tmp of
2: fpu := 25.4; // inch
3: fpu := 10; // centimeter
else
fpu := 0.0
end;
fl := GetRawFloat('FocalLength');
if (fpu = 0.0) or (fl = 0.0) then
exit;
tmp := GetRawInt('FocalPlaneXResolution');
if (tmp <= 0) then
exit;
CCDWidth := Width * fpu / tmp;
tmp := GetRawInt('FocalPlaneYResolution');
if (tmp <= 0) then
exit;
CCDHeight := Height * fpu / tmp;
if CCDWidth*CCDHeight <= 0 then // if either is zero
begin
if not estimateValues then
exit;
ratio := LookupRatio()
end
else
ratio := Diag35mm / sqrt (sqr (CCDWidth) + sqr (CCDHeight));
fl35 := fl * ratio;
w := Round(fl35);
// now load it into the tag array
tmp := LookupTagDefn('FocalLengthIn35mmFilm');
if tmp = -1 then
exit;
LookUpE := TagTable[tmp];
NewE := LookupE;
NewE.Data := ansistring(Format('%0.2f',[fl35]));
NewE.FormatS := '%s mm';
SetLength(NewE.Raw, 2);
Move(w, NewE.Raw[1], 2);
NewE.TType := FMT_USHORT;
AddTagToArray(NewE);
TraceStr := TraceStr + crlf +
siif(ExifTrace > 0, 'tag[$' + IntToHex(tmp,4) + ']: ', '') +
NewE.Desc + dExifDelim + NewE.Data +
siif(ExifTrace > 0,' [size: 0]', '') +
siif(ExifTrace > 0,' [start: 0]', '');
end;
procedure TImageInfo.EXIFArrayToXML(AList: TStrings);
var
i: integer;
begin
Assert(AList <> nil, 'TImageInfo.ExifArrayToXML called with AList=nil.');
AList.Add(' <EXIFdata>');
for i := 0 to fiTagCount-1 do
with fITagArray[i] do
begin
AList.Add(' <' + Name + '>');
if Tag in [105, 120] // headline and image caption // wp: ?? 105 = $0069, 120 = $0078 -- there are no such tags!
then AList.Add(' <![CDATA[' + Data + ']]>')
else AList.Add(' ' + Data);
AList.Add(' </' + Name + '>');
end;
AList.Add(' </EXIFdata>');
end;
end.
Reference in New Issue View Git Blame Copy Permalink