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 := ''; 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 := ''; } 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 := ''; 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(' '); 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(' ') else AList.Add(' ' + Data); AList.Add(' '); end; AList.Add(' '); end; end.