JPG-Header lesen und speichern

Hallo,

wenn ich das richtig verstehe, geht's dir um die EXIF-Infos. Die kannst du mit

dieser Unit auslesen und wieder (unverändert) speichern.

Delphi-Quellcode:

			uses

  dEXIF;

var

  ImgData: TImgData;

ImgData := TimgData.Create;

try

  ImgData.ProcessFile('Ladepfad\bild.jpg');

  // hier das Bild bearbeiten und, falls nicht bereits geschehen, in einem TJPEGImage ablegen

  ImgData.WriteEXIFJpeg(JpegImage, 'Zielpfad\bild.jpg');

finally

  FreeAndNil(ImgData);

end;

Bei mir funktioniert's.

Grüße

Leider funktioniert dieser Link nicht mehr !

Zitat von himitsu:

eventuell handelt es sich hierbei um die gewünschte Datei
Bei Google suchen

dEXIF.pas >

http://my-svn.assembla.com/svn/App_Smallsee/dEXIF.pas

Leider funktioniert auch dieser Link nicht mehr !

...........

zusammenfalten · markieren

Delphi-Quellcode:

			// 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 

//-------------------------------------------------------------------------- 

Unit dEXIF; 

interface 

uses sysutils,classes,math,diptc 

{$IFNDEF dExifNoJpeg} 

,jpeg 

{$ENDIF}; 

Const 

   DexifVersion = '1.02a'; 

   ExifTag = 1;  // default tag Types 

   GpsTag = 2; 

   ThumbTag = 4; 

   GenericEXIF = 0; 

   CustomEXIF = 1; 

   AllEXIF = -1; 

   crlf = #13#10; 

   GenNone = 0; 

   GenAll = 255; 

   GenString = 2; 

   GenList = 4; 

   VLMin = 0; 

   VLMax = 1; 

type 

   tEndInd = class 

      MotorolaOrder: boolean; 

      function Get16u(oset: integer): word; 

      function Get32s(oset: integer): Longint; 

      function Get32u(oset: integer): Longword; 

      function Put32s(data: Integer): string; 

      procedure WriteInt16(var buff:string;int,posn:integer); 

      procedure WriteInt32(var buff:string;int,posn:longint); 

      function GetDataBuff: string; 

      procedure SetDataBuff(const Value: string); 

      property DataBuff:string read GetDataBuff write SetDataBuff; 

   private 

      llData: string; 

   end; 

  TimgData = class; 

  TImageInfo = class(tEndind) 

  private 

    function GetTagElement(TagID: integer): TTagEntry; 

    procedure SetTagElement(TagID: integer; const Value: TTagEntry); 

    function GetTagByName(TagName: string): TTagEntry; 

    procedure SetTagByName(TagName: string; const Value: TTagEntry); 

    procedure TagWriteThru16(te: ttagentry; NewVal16: word); 

    procedure TagWriteThru32(te: ttagentry; NewVal32: longint); 

  public 

    FITagArray: array of tTagEntry; 

    FITagCount: integer; 

    MaxTag: integer; 

    parent: timgdata; 

    exifVersion : string[6]; 

    CameraMake: string[32]; 

    CameraModel: string[40]; 

    DateTime: string[20]; 

    Height,Width,HPosn,WPosn: integer; 

    FlashUsed: integer; 

    BuildList: integer; 

    MakerNote: string; 

    TiffFmt: boolean; 

    Comments: string; 

    CommentPosn: integer; 

    CommentSize: integer; 

// DateTime tag locations 

    dt_oset:integer; 

    dt_orig_oset:integer; 

    dt_digi_oset:integer; 

// Add support for thumbnail 

    ThumbTrace:string; 

    ThumbStart: integer; 

    ThumbLength: integer; 

    ThumbType: integer; 

    FIThumbArray: array of tTagEntry; 

    FIThumbCount: integer; 

    MaxThumbTag: integer; 

//  Added the following elements to make the 

//  structure a little more code-friendly 

    TraceLevel: integer; 

    TraceStr: string; 

    msTraceStr: string; 

    msAvailable: boolean; 

    msName:string; 

    MakerOffset : integer; 

    property ITagArray[TagID:integer]: TTagEntry 

        read GetTagElement write SetTagElement; default; 

    property Data[TagName:string]: TTagEntry 

        read GetTagByName write SetTagByName; 

    Constructor Create( p:timgdata; buildCode:integer =GenAll); 

    procedure Assign(source:TImageInfo); 

//  The following functions format this structure into a string 

    function  toString:string;   //  Summerizes in a single line 

    function  toLongString:string; 

    procedure SetExifComment(newComment: string); 

//  The following functions manage the date 

    function  GetImgDateTime: TDateTime; 

    function  ExtrDateTime(oset: integer): TDateTime; 

    function  ExifDateToDateTime(dstr: string): TDateTime; 

    procedure SetDateTimeStr(oset: integer; TimeIn: TDateTime); 

    procedure AdjDateTime(days, hours, mins, secs: integer); 

    procedure OverwriteDateTime(InTime: tdatetime);   //  Contains embedded CR/LFs 

    procedure ProcessHWSpecific(MakerBuff:string; 

                  TagTbl:Array of TTagEntry; 

                  DirStart:longint; 

                  MakerOffset:Longint; 

                  spOffset:integer = 0); 

    Procedure ProcessThumbnail; 

    Procedure AddMSTag(fname,fstr:string;fType:word); 

    Procedure ProcessExifDir(DirStart, OffsetBase, ExifLength: longint; 

             tagType:integer = ExifTag; prefix:string=''); 

    function CvtInt(buff: string): longint; 

    Function FormatNumber(buffer: string; fmt: integer; fmtStr:string; 

      decodeStr: string=''): string; 

    Function GetNumber(buffer: string; fmt: integer): double; 

    procedure removeThumbnail; 

    procedure AdjExifSize(nh,nw:longint); 

    Function LookupTag(SearchStr:string):integer; virtual; 

    Function LookupTagVal(SearchStr:string):string; virtual; 

    Function LookupTagDefn(item: string): integer; 

    Function LookupTagByDesc(SearchStr: string): integer; 

    function AddTagToArray(nextTag: iTag): integer; 

    function AddTagToThumbArray(nextTag: iTag): integer; 

    Procedure ResetIterator; 

    Function IterateFoundTags(TagId:integer; var retVal:TTagEntry):boolean; 

    Function GetTagByDesc(SearchStr: string): TTagEntry; 

    Function HasThumbnail:boolean; 

    function IterateFoundThumbTags(TagId: integer; 

      var retVal: TTagEntry): boolean; 

    procedure ResetThumbIterator; 

    procedure Calc35Equiv; 

    function EXIFArrayToXML: tstringlist; 

    function LookupTagInt(SearchStr: string): integer; 

    function GetRawFloat(tagName: string): double; 

    function GetRawInt(tagName: string): integer; 

    function LookupRatio: double; 

    destructor Destroy; override; 

    function WriteThruInt(tname: string; value: Integer): boolean; 

    function WriteThruString(tname, value: String): boolean; 

  private 

    iterator:integer; 

    iterThumb:integer; 

  end; // TInfoData 

  tSection = record 

    data: string; 

    dtype:integer; 

    size:longint; 

    base:longint; 

  end; 

  pSection = ^tSection; 

 // TTagTableArray = array of TTagEntry; 

  TGpsFormat = (gf_DD,gf_DM,gf_DMS); 

    TImgData = class(tEndInd) // One per image object 

        sections: array [1..21] of tSection; 

        TiffFmt: boolean; 

        BuildList: integer; 

        SectionCnt : integer; 

        ExifSegment: pSection; 

        IPTCSegment: pSection; 

        CommentSegment: pSection; 

        HeaderSegment : pSection; 

        Filename: string; 

        FileDateTime: tDateTime; 

        FileSize: longint; 

        ErrStr: string; 

        ExifObj: TImageInfo; 

        IptcObj: TIPTCData; 

        TraceLevel: integer; 

        procedure reset; 

        procedure SetFileInfo(fname:string); 

        constructor Create(buildCode: integer = GenAll); 

        function SaveExif(var jfs2:tstream):longint; 

        function ReadExifInfo(fname:string):boolean; 

        Procedure MakeIPTCSegment(buff:string); 

        Procedure MakeCommentSegment(buff:string); 

        function  GetCommentStr:string; 

        Function  GetCommentSegment:string; 

        function ProcessFile(const FileName:string):boolean; 

        function ReadJpegSections (var f: tstream):boolean; 

        function ReadJpegFile(const FileName:string):boolean; 

        function ReadTiffSections (var f: tstream):boolean; 

        function ReadTiffFile(const FileName:string):boolean; 

        procedure ProcessEXIF; 

        procedure CreateIPTCObj; 

        function  HasMetaData:boolean; 

        function HasEXIF: boolean; 

        function HasIPTC: boolean; 

        function HasComment: boolean; 

        function HasThumbnail: boolean; 

        function ReadIPTCStrings(fname: string):tstringlist; 

        function ExtractThumbnailBuffer: String; 

{$IFNDEF dExifNoJpeg} 

        procedure WriteEXIFJpeg(j:tjpegimage;fname:string;origName:string; 

                  adjSize:boolean = true);  overload; 

        procedure WriteEXIFJpeg(fname:string); overload; 

        procedure WriteEXIFJpeg(j:tjpegimage;fname:string; adjSize:boolean = true);  overload; 

        function ExtractThumbnailJpeg: TJpegImage; 

        function MetaDataToXML: tstringlist; 

        function FillInIptc:boolean; 

  public 

    destructor Destroy; override; 

{$ENDIF} 

    end; // TImgData 

  // these function variables can be overridden to 

  // alter the default formatting for various data types 

  tfmtInt  = function (inInt:integer):string; 

  tfmtReal = function (inReal:double):string; 

  tfmtFrac = function (inNum,inDen:integer):string; 

  // These formatting functions can be used elsewhere 

  function defIntFmt (inInt:integer):string; 

  function defRealFmt(inReal:double):string; 

  function defFracFmt(inNum,inDen:integer):string; 

  function fmtRational( num,den:integer):string; 

  function getbyte( var f : tstream) : byte; 

  function DecodeField(DecodeStr, idx: string): string; 

  function CvtTime(instr: string): string; 

Var 

   DexifDataSep   : string = ', '; 

   DexifDecodeSep : string = ','; 

   DexifDelim     : string = ' = '; 

   DexifDecode    : boolean = true; 

   estimateValues : boolean = false; 

   TiffReadLimit  : longint = 256000; 

   curTagArray    : TImageInfo = nil; 

   fmtInt: tfmtInt = defIntFmt; 

   fmtReal: tfmtReal = defRealFmt; 

   fmtFrac: tfmtFrac = defFracFmt; 

Const 

   GpsFormat = gf_DMS; 

   validHeader: string = 'Exif'#0; 

{ object declared in dIPTC unit 

  TTagEntry = record 

    TID: integer;        // TagTableID - EXIF use 

    TType: word;         // tag type 

    ICode: Word;         // iptc code 

    Tag: word;           // primary key 

    Name: string;        // searchable 

    Desc: string;        // translatable 

    Code: string;        // decode capability 

    Data:String;         // display value 

    Raw:string;          // unprocessed value 

    Fmt:string;          // Format string 

    Size: integer;       // used by ITPC module 

    CallBack: StrFunct;  // formatting string 

  end; 

} 

   EmptyEntry: ttagEntry = ( TID:0; TType:0; ICode:0; Tag:0; Name: ''; 

       Desc: ''; Code:''; Data:''; FormatS:''; Size:0); 

//-------------------------------------------------------------------------- 

// JPEG markers consist of one or more= $FF bytes, followed by a marker 

// code byte (which is not an FF).  Here are the marker codes of interest 

// in this program. 

//-------------------------------------------------------------------------- 

     M_SOF0 = $C0;            // Start Of Frame N 

     M_SOF1 = $C1;            // N indicates which compression process 

     M_SOF2 = $C2;            // Only SOF0-SOF2 are now in common use 

     M_SOF3 = $C3; 

     M_DHT  = $C4;            // Define Huffman Table 

     M_SOF5 = $C5;            // NB: codes C4 and CC are NOT SOF markers 

     M_SOF6 = $C6; 

     M_SOF7 = $C7; 

     M_SOF9 = $C9; 

     M_SOF10= $CA; 

     M_SOF11= $CB; 

     M_SOF13= $CD;                              M_DAC  = $CC;            // Define arithmetic coding conditioning 

     M_SOF14= $CE; 

     M_SOF15= $CF; 

     M_SOI  = $D8;            // Start Of Image (beginning of datastream) 

     M_EOI  = $D9;            // End Of Image (end of datastream) 

     M_SOS  = $DA;            // Start Of Scan (begins compressed data) 

     M_DQT  = $DB;            // Define Quantization table 

     M_DNL  = $DC;            // Define number of lines 

     M_DRI  = $DD;            // Restart interoperability definition 

     M_DHP  = $DE;            // Define hierarchical progression 

     M_EXP  = $DF;            // Expand reference component 

     M_JFIF = $E0;            // Jfif marker 

     M_EXIF = $E1;            // Exif marker 

  M_EXIFEXT = $E2;            // Exif extended marker 

     //  M_KODAK = $E3;           // Kodak marker  ??? 

     M_IPTC = $ED;            // IPTC - Photoshop 

    M_APP14 = $EE;            // Photoshop data:  App14 

     M_COM  = $FE;            // Comment 

    ProcessTable : array [0..29] of TTagEntry = 

    (( Tag: M_SOF0;   Desc: 'Baseline'), 

     ( Tag: M_SOF1;   Desc: 'Extended sequential'), 

     ( Tag: M_SOF2;   Desc: 'Progressive'), 

     ( Tag: M_SOF3;   Desc: 'Lossless'), 

     ( Tag: M_DHT;    Desc: 'Define Huffman table'), 

     ( Tag: M_SOF5;   Desc: 'Differential sequential'), 

     ( Tag: M_SOF6;   Desc: 'Differential progressive'), 

     ( Tag: M_SOF7;   Desc: 'Differential lossless'), 

     ( Tag: M_SOF9;   Desc: 'Extended sequential, arithmetic coding'), 

     ( Tag: M_SOF10;  Desc: 'Progressive, arithmetic coding'), 

     ( Tag: M_SOF11;  Desc: 'Lossless, arithmetic coding'), 

     ( Tag: M_SOF13;  Desc: 'Differential sequential, arithmetic coding'), 

     ( Tag: M_DAC;    Desc: 'Define arithmetic coding conditioning'), 

     ( Tag: M_SOF14;  Desc: 'Differential progressive, arithmetic coding'), 

     ( Tag: M_SOF15;  Desc: 'Differential lossless, arithmetic coding'), 

     ( Tag: M_SOI;    Desc: 'Start of Image'), 

     ( Tag: M_EOI;    Desc: 'End of Image'), 

     ( Tag: M_SOS;    Desc: 'Start of Scan'), 

     ( Tag: M_DQT;    Desc: 'Define quantization table'), 

     ( Tag: M_DNL;    Desc: 'Define number of lines'), 

     ( Tag: M_DRI;    Desc: 'Restart interoperability definition'), 

     ( Tag: M_DHP;    Desc: 'Define hierarchical progression'), 

     ( Tag: M_EXP;    Desc: 'Expand reference component'), 

     ( Tag: M_JFIF;   Desc: 'JPG marker'), 

     ( Tag: M_EXIF;   Desc: 'Exif Data'), 

     ( Tag: M_EXIFEXT; Desc: 'Exif Extended Data'), 

     ( Tag: M_COM;    Desc: 'Comment'), 

     ( Tag: M_IPTC;   Desc: 'IPTC data'), 

     ( Tag: M_APP14;  Desc: 'Photoshop data'), 

     ( Tag: 0;        Desc: 'Unknown') 

    ); 

   Function CvtIrrational( instr:string ):double; 

   Function LookupType(idx:integer):string; 

   Function MakePrintable(s:string):string; 

   //  Formatting callbacks 

   Function GpsPosn(instr:string) :string; 

   Function GenCompConfig(instr:string): string; 

   Function ExposCallBack(instr: string): string; 

   Function FlashCallBack(instr: string): string; 

   Function ExtractComment(instr: string): string; 

   Function SSpeedCallBack(instr: string): string; 

   Function xpTranslate(instr: string): string; 

const 

//-------------------------------------------------------------------------- 

// Describes format descriptor 

   BytesPerFormat: array [0..12] of integer = (0,1,1,2,4,8,1,1,2,4,8,4,8); 

   NUM_FORMATS   = 12; 

   FMT_BYTE      =  1; 

   FMT_STRING    =  2; 

   FMT_USHORT    =  3; 

   FMT_ULONG     =  4; 

   FMT_URATIONAL =  5; 

   FMT_SBYTE     =  6; 

   FMT_UNDEFINED =  7; 

   FMT_SSHORT    =  8; 

   FMT_SLONG     =  9; 

   FMT_SRATIONAL = 10; 

   FMT_SINGLE    = 11; 

   FMT_DOUBLE    = 12; 

var 

  ExifNonThumbnailLength : integer; 

  ShowTags: integer; 

  ExifTrace: integer = 0; 

{$IFDEF dEXIFpredeclare} 

  ImgData:timgData; 

{$ENDIF} 

implementation 

uses msData; 

const 

// Compression Type Constants 

   JPEG_COMP_TYPE = 6; 

   TIFF_COMP_TYPE = 1; 

//------------------------------------------------------- 

// Describes only tag values needed for physical access 

// all others are found in tag array. 

//------------------------------------------------------- 

   TAG_EXIF_OFFSET      = $8769; 

   TAG_GPS_OFFSET       = $8825; 

   TAG_INTEROP_OFFSET   = $A005; 

   TAG_SUBIFD_OFFSET    = $014A; 

   TAG_MAKE             = $010F; 

   TAG_MODEL            = $0110; 

   TAG_EXIFVER          = $9000; 

   TAG_DATETIME         = $0132; 

(* 

   TAG_EXPOSURETIME     = $829A; 

   TAG_FNUMBER          = $829D; 

   TAG_SHUTTERSPEED     = $9201; 

   TAG_APERTURE         = $9202; 

   TAG_MAXAPERTURE      = $9205; 

   TAG_FOCALLENGTH      = $920A; 

   TAG_FOCALLENGTH35MM  = $A405;             // added by M. Schwaiger 

   TAG_SUBJECT_DISTANCE = $9206; 

   TAG_LIGHT_SOURCE     = $9208; 

   TAG_FOCALPLANEXRES   = $a20E; 

   TAG_FOCALPLANEYRES   = $a20F;             // added by M. Schwaiger 

   TAG_FOCALPLANEUNITS  = $a210; 

*) 

   TAG_THUMBTYPE          = $0103; 

   TAG_DATETIME_ORIGINAL  = $9003; 

   TAG_DATETIME_DIGITIZED = $9004; 

   TAG_USERCOMMENT        = $9286; 

   TAG_FLASH              = $9209; 

   TAG_MAKERNOTE          = $927C; 

   TAG_EXIF_IMAGEWIDTH    = $A002; 

   TAG_EXIF_IMAGELENGTH   = $A003; 

   TAG_IMAGEWIDTH         = $0100; 

   TAG_IMAGELENGTH        = $0101; 

   GPSCnt = 30; 

   ExifTagCnt = 250; 

   TotalTagCnt = GPSCnt+ExifTagCnt; 

{   Many tags added based on Php4 source... 

http://lxr.php.net/source/php4/ext/exif/exif.c 

} 

var 

 TagTable : array [0..ExifTagCnt] of TTagEntry = 

// TagTable : array of TTagEntry = 

// TagTable : TTagDefArray [0..ExifTagCnt] = 

// TagTable: TTagDefArray = 

 ((Tag: $001;   Name:'InteroperabilityIndex'  ), 

  (Tag: $002;   Name:'InteroperabilityVersion'), 

  (Tag: $00B;   Name:'ACDComment'             ), 

  (Tag: $0FE;   Name:'NewSubfileType'         ), 

  (Tag: $0FF;   Name:'SubfileType'            ), 

  (Tag: $100;   Name:'ImageWidth'             ), 

  (Tag: $101;   Name:'ImageLength'            ), 

  (Tag: $102;   Name:'BitsPerSample'          ), 

  (Tag: $103;   Name:'Compression'            ;Code:'6:Jpeg,3:Uncompressed,1:TIFF'), 

  (Tag: $106;   Name:'PhotometricInterpretation'; Code:'1:Monochrome, 2:RGB, 6:YCbCr'), 

  (Tag: $10A;   Name:'FillOrder'              ), 

  (Tag: $10D;   Name:'DocumentName'           ), 

  (Tag: $10E;   Name:'ImageDescription'       ), 

  (Tag: $10F;   Name:'Make'                   ), 

  (Tag: $110;   Name:'Model'                  ), 

  (Tag: $111;   Name:'StripOffsets'           ), 

  (Tag: $112;   Name:'Orientation'            ; Code:'1:Normal,3:Rotated 180°,6:CounterClockwise 90°,8:Clockwise 90°'), 

  (Tag: $115;   Name:'SamplesPerPixel'        ), 

  (Tag: $116;   Name:'RowsPerStrip'           ), 

  (Tag: $117;   Name:'StripByteCounts'        ), 

  (Tag: $118;   Name:'MinSampleValue'         ), 

  (Tag: $119;   Name:'MaxSampleValue'         ), 

  (Tag: $11A;   Name:'XResolution'            ; FormatS:'%5.2f'), 

  (Tag: $11B;   Name:'YResolution'            ; FormatS:'%5.2f'), 

  (Tag: $11C;   Name:'PlanarConfiguration'    ), 

  (Tag: $11D;   Name:'PageName'               ), 

  (Tag: $11E;   Name:'XPosition'              ), 

  (Tag: $11F;   Name:'YPosition'              ), 

  (Tag: $120;   Name:'FreeOffsets'            ), 

  (Tag: $121;   Name:'FreeByteCounts'         ), 

  (Tag: $122;   Name:'GrayReponseUnit'        ), 

  (Tag: $123;   Name:'GrayReponseCurve'       ), 

  (Tag: $124;   Name:'T4Options'              ), 

  (Tag: $125;   Name:'T6Options'              ), 

  (Tag: $128;   Name:'ResolutionUnit'         ; Code:'1:None Specified,2:Inch,3:Centimeter'),        // ; Code:'' 

  (Tag: $129;   Name:'PageNumber'             ),        // ; Code:'' 

  (Tag: $12D;   Name:'TransferFunction'       ), 

  (Tag: $131;   Name:'Software'               ), 

  (Tag: $132;   Name:'DateTime'               ), 

  (Tag: $13B;   Name:'Artist'                 ), 

  (Tag: $13C;   Name:'HostComputer'           ), 

  (Tag: $13D;   Name:'Predictor'              ), 

  (Tag: $13E;   Name:'WhitePoint'             ), 

  (Tag: $13F;   Name:'PrimaryChromaticities'  ), 

  (Tag: $140;   Name:'ColorMap'               ), 

  (Tag: $141;   Name:'HalfToneHints'          ), 

  (Tag: $142;   Name:'TileWidth'              ), 

  (Tag: $143;   Name:'TileLength'             ), 

  (Tag: $144;   Name:'TileOffsets'            ), 

  (Tag: $145;   Name:'TileByteCounts'         ), 

  (Tag: $14A;   Name:'SubIFDs'                ), 

  (Tag: $14C;   Name:'InkSet'                 ), 

  (Tag: $14D;   Name:'InkNames'               ), 

  (Tag: $14E;   Name:'NumberOfInks'           ), 

  (Tag: $150;   Name:'DotRange'               ), 

  (Tag: $151;   Name:'TargetPrinter'          ), 

  (Tag: $152;   Name:'ExtraSample'            ), 

  (Tag: $153;   Name:'SampleFormat'           ), 

  (Tag: $154;   Name:'SMinSampleValue'        ), 

  (Tag: $155;   Name:'SMaxSampleValue'        ), 

  (Tag: $156;   Name:'TransferRange'          ), 

  (Tag: $157;   Name:'ClipPath'               ), 

  (Tag: $158;   Name:'XClipPathUnits'         ), 

  (Tag: $159;   Name:'YClipPathUnits'         ), 

  (Tag: $15A;   Name:'Indexed'                ), 

  (Tag: $15B;   Name:'JPEGTables'             ), 

  (Tag: $15F;   Name:'OPIProxy'               ), 

  (Tag: $200;   Name:'JPEGProc'               ), 

  (Tag: $201;   Name:'JPEGInterchangeFormat'  ), 

  (Tag: $202;   Name:'JPEGInterchangeFormatLength'), 

  (Tag: $203;   Name:'JPEGRestartInterval'    ), 

  (Tag: $205;   Name:'JPEGLosslessPredictors' ), 

  (Tag: $206;   Name:'JPEGPointTransforms'    ), 

  (Tag: $207;   Name:'JPEGQTables'            ), 

  (Tag: $208;   Name:'JPEGDCTables'           ), 

  (Tag: $209;   Name:'JPEGACTables'           ), 

  (Tag: $211;   Name:'YCbCrCoefficients'      ), 

  (Tag: $212;   Name:'YCbCrSubSampling'       ), 

  (Tag: $213;   Name:'YCbCrPositioning'       ; Code:'1:Centered,2:Co-sited'), 

  (Tag: $214;   Name:'ReferenceBlackWhite'    ), 

  (Tag: $2BC;   Name:'ExtensibleMetadataPlatform' ), 

  (Tag: $301;   Name:'Gamma'                     ), 

  (Tag: $302;   Name:'ICCProfileDescriptor'      ), 

  (Tag: $303;   Name:'SRGBRenderingIntent'       ), 

  (Tag: $304;   Name:'ImageTitle'                ), 

  (Tag: $1000;  Name:'RelatedImageFileFormat' ), 

  (Tag: $1001;  Name:'RelatedImageWidth'      ), 

  (Tag: $1002;  Name:'RelatedImageHeight'     ), 

  (Tag: $5001;  Name:'ResolutionXUnit'        ), 

  (Tag: $5002;  Name:'ResolutionYUnit'        ), 

  (Tag: $5003;  Name:'ResolutionXLengthUnit'  ), 

  (Tag: $5004;  Name:'ResolutionYLengthUnit'  ), 

  (Tag: $5005;  Name:'PrintFlags'             ), 

  (Tag: $5006;  Name:'PrintFlagsVersion'      ), 

  (Tag: $5007;  Name:'PrintFlagsCrop'         ), 

  (Tag: $5008;  Name:'PrintFlagsBleedWidth'   ), 

  (Tag: $5009;  Name:'PrintFlagsBleedWidthScale'), 

  (Tag: $500A;  Name:'HalftoneLPI'            ), 

  (Tag: $500B;  Name:'HalftoneLPIUnit'        ), 

  (Tag: $500C;  Name:'HalftoneDegree'         ), 

  (Tag: $500D;  Name:'HalftoneShape'          ), 

  (Tag: $500E;  Name:'HalftoneMisc'           ), 

  (Tag: $500F;  Name:'HalftoneScreen'         ), 

  (Tag: $5010;  Name:'JPEGQuality'            ), 

  (Tag: $5011;  Name:'GridSize'               ), 

  (Tag: $5012;  Name:'ThumbnailFormat'        ), 

  (Tag: $5013;  Name:'ThumbnailWidth'         ), 

  (Tag: $5014;  Name:'ThumbnailHeight'        ), 

  (Tag: $5015;  Name:'ThumbnailColorDepth'    ), 

  (Tag: $5016;  Name:'ThumbnailPlanes'        ), 

  (Tag: $5017;  Name:'ThumbnailRawBytes'      ), 

  (Tag: $5018;  Name:'ThumbnailSize'          ), 

  (Tag: $5019;  Name:'ThumbnailCompressedSize'), 

  (Tag: $501A;  Name:'ColorTransferFunction'  ), 

  (Tag: $501B;  Name:'ThumbnailData'          ), 

  (Tag: $5020;  Name:'ThumbnailImageWidth'    ), 

  (Tag: $5021;  Name:'ThumbnailImageHeight'   ), 

  (Tag: $5022;  Name:'ThumbnailBitsPerSample' ), 

  (Tag: $5023;  Name:'ThumbnailCompression'   ), 

  (Tag: $5024;  Name:'ThumbnailPhotometricInterp'), 

  (Tag: $5025;  Name:'ThumbnailImageDescription' ), 

  (Tag: $5026;  Name:'ThumbnailEquipMake'     ), 

  (Tag: $5027;  Name:'ThumbnailEquipModel'    ), 

  (Tag: $5028;  Name:'ThumbnailStripOffsets'  ), 

  (Tag: $5029;  Name:'ThumbnailOrientation'   ), 

  (Tag: $502A;  Name:'ThumbnailSamplesPerPixel'), 

  (Tag: $502B;  Name:'ThumbnailRowsPerStrip'  ), 

  (Tag: $502C;  Name:'ThumbnailStripBytesCount'), 

  (Tag: $502D;  Name:'ThumbnailResolutionX'   ), 

  (Tag: $502E;  Name:'ThumbnailResolutionY'   ), 

  (Tag: $502F;  Name:'ThumbnailPlanarConfig'  ), 

  (Tag: $5030;  Name:'ThumbnailResolutionUnit'), 

  (Tag: $5031;  Name:'ThumbnailTransferFunction'), 

  (Tag: $5032;  Name:'ThumbnailSoftwareUsed'  ), 

  (Tag: $5033;  Name:'ThumbnailDateTime'      ), 

  (Tag: $5034;  Name:'ThumbnailArtist'        ), 

  (Tag: $5035;  Name:'ThumbnailWhitePoint'    ), 

  (Tag: $5036;  Name:'ThumbnailPrimaryChromaticities'), 

  (Tag: $5037;  Name:'ThumbnailYCbCrCoefficients'    ), 

  (Tag: $5038;  Name:'ThumbnailYCbCrSubsampling'     ), 

  (Tag: $5039;  Name:'ThumbnailYCbCrPositioning'     ), 

  (Tag: $503A;  Name:'ThumbnailRefBlackWhite' ), 

  (Tag: $503B;  Name:'ThumbnailCopyRight'     ), 

  (Tag: $5090;  Name:'LuminanceTable'         ), 

  (Tag: $5091;  Name:'ChrominanceTable'       ), 

  (Tag: $5100;  Name:'FrameDelay'             ), 

  (Tag: $5101;  Name:'LoopCount'              ), 

  (Tag: $5110;  Name:'PixelUnit'              ), 

  (Tag: $5111;  Name:'PixelPerUnitX'          ), 

  (Tag: $5112;  Name:'PixelPerUnitY'          ), 

  (Tag: $5113;  Name:'PaletteHistogram'       ), 

  (Tag: $800D;  Name:'ImageID'                ), 

  (Tag: $80E3;  Name:'Matteing'               ),   //* obsoleted by ExtraSamples */ 

  (Tag: $80E4;  Name:'DataType'               ),   //* obsoleted by SampleFormat */ 

  (Tag: $80E5;  Name:'ImageDepth'             ), 

  (Tag: $80E6;  Name:'TileDepth'              ), 

  (Tag: $828D;  Name:'CFARepeatPatternDim'    ), 

  (Tag: $828E;  Name:'CFAPattern'             ), 

  (Tag: $828F;  Name:'BatteryLevel'           ), 

  (Tag: $8298;  Name:'Copyright'              ), 

  (Tag: $829A;  Name:'ExposureTime'             ; Formats:'%s sec'), 

  (Tag: $829D;  Name:'FNumber'                  ; FormatS:'F%0.1f'), 

  (Tag: $83BB;  Name:'IPTC/NAA'                 ; Desc:'IPTC/NAA'), 

  (Tag: $84E3;  Name:'IT8RasterPadding'         ), 

  (Tag: $84E5;  Name:'IT8ColorTable'            ), 

  (Tag: $8649;  Name:'ImageResourceInformation' ), 

  (Tag: $8769;  Name:'ExifOffset'               ), 

  (Tag: $8773;  Name:'InterColorProfile'        ), 

  (Tag: $8822;  Name:'ExposureProgram'          ; Code: 

        '0:Unidentified,1:Manual,2:Normal,3:Aperture priority,'+ 

        '4:Shutter priority,5:Creative(slow),'+ 

        '6:Action(high-speed),7:Portrait mode,8:Landscape mode'), 

  (Tag: $8824;  Name:'SpectralSensitivity'    ), 

  (Tag: $8825;  Name:'GPSInfo'                ), 

  (Tag: $8827;  Name:'ISOSpeedRatings'        ), 

  (Tag: $8828;  Name:'OECF'                   ), 

  (Tag: $8829;  Name:'Interlace'              ), 

  (Tag: $882A;  Name:'TimeZoneOffset'         ), 

  (Tag: $882B;  Name:'SelfTimerMode'          ), 

  (Tag: $9000;  Name:'ExifVersion'            ), 

  (Tag: $9003;  Name:'DateTimeOriginal'       ), 

  (Tag: $9004;  Name:'DateTimeDigitized'      ), 

  (Tag: $9101;  Name:'ComponentsConfiguration'; Callback: GenCompConfig), 

  (Tag: $9102;  Name:'CompressedBitsPerPixel' ), 

  (Tag: $9201;  Name:'ShutterSpeedValue'      ; Callback: SSpeedCallBack), 

  (Tag: $9202;  Name:'ApertureValue'          ; FormatS:'F%0.1f'), 

  (Tag: $9203;  Name:'BrightnessValue'        ), 

  (Tag: $9204;  Name:'ExposureBiasValue'      ), 

  (Tag: $9205;  Name:'MaxApertureValue'       ; FormatS:'F%0.1f'), 

  (Tag: $9206;  Name:'SubjectDistance'        ), 

  (Tag: $9207;  Name:'MeteringMode'           ; Code:'0:Unknown,1:Average,2:Center,3:Spot,4:MultiSpot,5:MultiSegment,6:Partial'), 

  (Tag: $9208;  Name:'LightSource'            ; Code:'0:Unidentified,1:Daylight,2:Fluorescent,3:Tungsten,10:Flash,17:Std A,18:Std B,19:Std C'), 

  (Tag: $9209;  Name:'Flash'                  ; CallBack:FlashCallBack), 

  (Tag: $920A;  Name:'FocalLength'            ; FormatS:'%5.2f mm'), 

  (Tag: $920B;  Name:'FlashEnergy'             ), 

  (Tag: $920C;  Name:'SpatialFrequencyResponse'), 

  (Tag: $920D;  Name:'Noise'                   ), 

  (Tag: $920E;  Name:'FocalPlaneXResolution'   ),      // Tag: $920E    -  - 

  (Tag: $920F;  Name:'FocalPlaneYResolution'   ),       // Tag: $920F    -  - 

  (Tag: $9210;  Name:'FocalPlaneResolutionUnit';  Code:'1:None Specified,2:Inch,3:Centimeter'),      // Tag: $9210    -  - 

  (Tag: $9211;  Name:'ImageNumber'            ), 

  (Tag: $9212;  Name:'SecurityClassification' ), 

  (Tag: $9213;  Name:'ImageHistory'           ), 

  (Tag: $9214;  Name:'SubjectLocation'        ), 

  (Tag: $9215;  Name:'ExposureIndex'          ), 

  (Tag: $9216;  Name:'TIFF/EPStandardID'      ), 

  (Tag: $9217;  Name:'SensingMethod'          ), 

  (Tag: $923F;  Name:'StoNits'                ), 

  (Tag: $927C;  Name:'MakerNote'              ), 

  (Tag: $9286;  Name:'UserComment'            ;  Callback: ExtractComment), 

  (Tag: $9290;  Name:'SubSecTime'             ), 

  (Tag: $9291;  Name:'SubSecTimeOriginal'     ), 

  (Tag: $9292;  Name:'SubSecTimeDigitized'    ), 

  (Tag: $953C;  Name:'ImageSourceData'        ),  // "Adobe Photoshop Document Data Block": 8BIM... 

  (Tag: $9C9B;  Name:'Title'                  ;  Callback: xpTranslate),  // Win XP specific, Unicode 

  (Tag: $9C9C;  Name:'Comments'               ;  Callback: xpTranslate),  // Win XP specific, Unicode 

  (Tag: $9C9D;  Name:'Author'                 ;  Callback: xpTranslate),  // Win XP specific, Unicode 

  (Tag: $9C9E;  Name:'Keywords'               ;  Callback: xpTranslate),  // Win XP specific, Unicode 

  (Tag: $9C9F;  Name:'Subject'                ;  Callback: xpTranslate),  // Win XP specific, Unicode 

  (Tag: $A000;  Name:'FlashPixVersion'        ), 

  (Tag: $A001;  Name:'ColorSpace'             ;  Code:'0:sBW,1:sRGB'), 

  (Tag: $A002;  Name:'ExifImageWidth'         ), 

  (Tag: $A003;  Name:'ExifImageLength'        ), 

  (Tag: $A004;  Name:'RelatedSoundFile'       ), 

  (Tag: $A005;  Name:'InteroperabilityOffset' ), 

  (Tag: $A20B;  Name:'FlashEnergy'            ),    // Tag: $920B in TIFF/EP 

  (Tag: $A20C;  Name:'SpatialFrequencyResponse'),   // Tag: $920C    -  - 

  (Tag: $A20E;  Name:'FocalPlaneXResolution'   ),      // Tag: $920E    -  - 

  (Tag: $A20F;  Name:'FocalPlaneYResolution'   ),       // Tag: $920F    -  - 

  (Tag: $A210;  Name:'FocalPlaneResolutionUnit'; Code:'1:None Specified,2:Inch,3:Centimeter'),      // Tag: $9210    -  - 

  (Tag: $A211;  Name:'ImageNumber'             ), 

  (Tag: $A212;  Name:'SecurityClassification'  ), 

  (Tag: $A213;  Name:'ImageHistory'            ), 

  (Tag: $A214;  Name:'SubjectLocation'         ), 

  (Tag: $A215;  Name:'ExposureIndex'           ), 

  (Tag: $A216;  Name:'TIFF/EPStandardID'       ;   Desc:'TIFF/EPStandardID' ), 

  (Tag: $A217;  Name:'SensingMethod'           ;   Code:'0:Unknown,1:MonochromeArea,'+ 

    '2:OneChipColorArea,3:TwoChipColorArea,4:ThreeChipColorArea,'+ 

    '5:ColorSequentialArea,6:MonochromeLinear,7:TriLinear,'+ 

    '8:ColorSequentialLinear'),                        // Tag: $9217    -  - 

  (Tag: $A300;  Name:'FileSource'              ;  Code:'1:Unknown,3:Digital Still Camera'), 

  (Tag: $A301;  Name:'SceneType'               ;  Code:'0:Unknown,1:Directly Photographed'), 

  (Tag: $A302;  Name:'CFAPattern'              ), 

  (Tag: $A401;  Name:'CustomRendered'          ;  Code:'0:Normal process,1:Custom process'), 

  (Tag: $A402;  Name:'ExposureMode'            ;  Code:'0:Auto,1:Manual,2:Auto bracket'), 

  (Tag: $A403;  Name:'WhiteBalance'            ;  Code:'0:Auto,1:Manual'), 

  (Tag: $A404;  Name:'DigitalZoomRatio'        ), 

  (Tag: $A405;  Name:'FocalLengthin35mmFilm'   ;  Desc:'Focal Length in 35mm Film'; FormatS:'%5.2f mm'), 

  (Tag: $A406;  Name:'SceneCaptureType'        ;  Code:'0:Standard,1:Landscape,2:Portrait,3:Night scene'), 

  (Tag: $A407;  Name:'GainControl'             ;  Code:'0:None,1:Low gain up,2:High gain up,3:Low gain down,4:High gain down'), 

  (Tag: $A408;  Name:'Contrast'                ;  Code:'0:Normal,1:Soft,2:Hard'), 

  (Tag: $A409;  Name:'Saturation'              ;  Code:'0:Normal,1:Low,2:High'), 

  (Tag: $A40A;  Name:'Sharpness'               ;  Code:'0:Normal,1:Soft,2:Hard'), 

  (Tag: $A40B;  Name:'DeviceSettingDescription'), 

  (Tag: $A40C;  Name:'SubjectDistanceRange'    ;  Code:'0:Unknown,1:Macro,2:Close view,3:Distant view'), 

  (Tag: $A420;  Name:'ImageUniqueID'           ;  Code:'0:Close view,1:Distant view'), 

  (Tag: 0;      Name:'Unknown')); 

 GPSTable : array [0..GPSCnt] of TTagEntry = 

 ((Tag: $000;   Name:'GPSVersionID'           ), 

  (Tag: $001;   Name:'GPSLatitudeRef'         ), 

  (Tag: $002;   Name:'GPSLatitude'            ;   CallBack:GpsPosn), 

  (Tag: $003;   Name:'GPSLongitudeRef'        ), 

  (Tag: $004;   Name:'GPSLongitude'           ;   CallBack:GpsPosn), 

  (Tag: $005;   Name:'GPSAltitudeRef'         ;   Code:'0:Sealevel'), 

  (Tag: $006;   Name:'GPSAltitude'            ), 

  (Tag: $007;   Name:'GPSTimeStamp'           ;   CallBack:CvtTime), 

  (Tag: $008;   Name:'GPSSatellites'          ), 

  (Tag: $009;   Name:'GPSStatus'              ), 

  (Tag: $00A;   Name:'GPSMeasureMode'         ), 

  (Tag: $00B;   Name:'GPSDOP'                 ), 

  (Tag: $00C;   Name:'GPSSpeedRef'            ), 

  (Tag: $00D;   Name:'GPSSpeed'               ), 

  (Tag: $00E;   Name:'GPSTrackRef'            ), 

  (Tag: $00F;   Name:'GPSTrack'               ), 

  (Tag: $010;   Name:'GPSImageDirectionRef'   ), 

  (Tag: $011;   Name:'GPSImageDirection'      ), 

  (Tag: $012;   Name:'GPSMapDatum'            ), 

  (Tag: $013;   Name:'GPSDestLatitudeRef'     ), 

  (Tag: $014;   Name:'GPSDestLatitude'        ;   CallBack:GpsPosn), 

  (Tag: $015;   Name:'GPSDestLongitudeRef'    ), 

  (Tag: $016;   Name:'GPSDestLongitude'       ;   CallBack:GpsPosn), 

  (Tag: $017;   Name:'GPSDestBearingkRef'     ), 

  (Tag: $018;   Name:'GPSDestBearing'         ), 

  (Tag: $019;   Name:'GPSDestDistanceRef'     ), 

  (Tag: $01A;   Name:'GPSDestDistance'        ), 

  (Tag: $01B;   Name:'GPSProcessingMode'      ), 

  (Tag: $01C;   Name:'GPSAreaInformation'     ), 

  (Tag: $01D;   Name:'GPSDateStamp'           ), 

  (Tag: $01E;   Name:'GPSDifferential'        ) 

  ); 

  tagInit : boolean = false; 

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; 

Function InsertSpaces(instr:string):string; 

var i:integer; 

  rslt:string; 

  tc:char; 

  lastUc:boolean; 

begin 

  LastUC := true; 

  rslt := copy(instr,1,1); 

  for i := 2 to length(instr) do 

  begin 

    tc := instr[i]; 

    if (tc >= 'A') and (tc <= 'Z') then 

    begin 

      if LastUC then 

        rslt := rslt+tc 

      else 

        rslt := rslt+' '+tc; 

      LastUc := true; 

    end 

    else 

    begin 

      lastUC := false; 

      rslt := rslt+tc; 

    end; 

  end; 

  result := rslt; 

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 CvtIrrational( instr:string ):double; 

var b1,b2:string; 

    intMult,op:integer; 

begin 

  result := 0.0; 

  instr := trim(instr); 

  try 

    op := pos(' ',instr); 

    if op > 0 then 

    begin 

      intMult := StrToint(copy(instr,1,op-1)); 

      instr := copy(instr,op+1,length(instr)); 

    end 

    else 

      intMult := 0; 

    op := pos('/',instr); 

    b1 := copy(instr,1,op-1); 

    b2 := copy(instr,op+1,length(instr)); 

    result := (intMult*StrToInt(b2)+StrToInt(b1)) / StrToInt(b2); 

  except 

  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 

    if ProcessTable[i].Tag = idx then 

      result := ProcessTable[i].desc; 

end; 

// These destructors provided by Keith Murray 

// of byLight Technologies - Thanks! 

Destructor TImageInfo.Destroy; 

begin 

  SetLength(fITagArray,0); 

  inherited; 

end; 

Destructor TImgdata.Destroy; 

begin 

  if assigned(ExifObj) then 

    ExifObj.free; 

  if assigned(IptcObj) then 

    IptcObj.free; 

  inherited; 

end; 

//  This function returns the index of a tag name 

//  in the tag buffer. 

Function TImageInfo.LookupTag(SearchStr:string):integer; 

var i: integer; 

begin 

 SearchStr := UpperCase(SearchStr); 

 result := -1; 

 for i := 0 to fiTagCount-1 do 

   if UpperCase(fiTagArray[i].Name) = SearchStr then 

   begin 

     result := i; 

     break; 

   end; 

end; 

//  This function returns the data value for a 

//  given tag name. 

Function TImageInfo.LookupTagVal(SearchStr:string):string; 

var i: integer; 

begin 

 SearchStr := UpperCase(SearchStr); 

 result := ''; 

 for i := 0 to fiTagCount-1 do 

   if UpperCase(fiTagArray[i].Name) = SearchStr then 

   begin 

     result := fiTagArray[i].Data; 

     break; 

   end; 

end; 

//  This function returns the data value for a 

//  given tag name. 

Function TImageInfo.LookupTagInt(SearchStr:string):integer; 

var i: integer; 

begin 

 SearchStr := UpperCase(SearchStr); 

 result := -1; 

 for i := 0 to fiTagCount-1 do 

   if UpperCase(fiTagArray[i].Name) = SearchStr then 

   begin 

     result := strtoint(fiTagArray[i].Data); 

     break; 

   end; 

end; 

//  This function returns the index of a tag name 

//  in the tag buffer. It searches by the description 

//  which is most likely to be used as a label 

Function TImageInfo.LookupTagByDesc(SearchStr:string):integer; 

var i: integer; 

begin 

 SearchStr := UpperCase(SearchStr); 

 result := -1; 

 for i := 0 to FITagCount-1 do 

   if UpperCase(fiTagArray[i].Desc) = SearchStr then 

   begin 

     result := i; 

     break; 

   end; 

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 definition 

//  for a given tag name. 

function TImageInfo.LookupTagDefn(item: string): integer; 

var i:integer; 

begin 

  result := -1; 

  for i := 0 to ExifTagCnt-1 do 

  begin 

    if lowercase(item) = lowercase(TagTable[i].Name) then 

    begin 

      result := i; 

      break; 

    end; 

  end; 

end; 

function LookupTagByID(idx:integer;TagType:integer=ExifTag):integer; 

var i:integer; 

begin 

  result := -1; 

  case tagType of 

    ThumbTag, 

    ExifTag: for i := 0 to ExifTagCnt do 

               if TagTable[i].Tag = idx then 

                 result := i; 

     GpsTag: for i := 0 to GPSCnt do 

               if GPSTable[i].Tag = idx then 

                 result := i; 

  else 

  end; 

end; 

function FetchTagByID(idx:integer;TagType:integer=ExifTag):TTagEntry; 

var i:integer; 

begin 

  result := TagTable[ExifTagCnt]; 

  case tagType of 

    ThumbTag, 

    ExifTag: for i := 0 to ExifTagCnt-1 do 

               if TagTable[i].Tag = idx then 

                 result := TagTable[i]; 

     GpsTag: for i := 0 to GPSCnt-1 do 

               if GPSTable[i].Tag = idx then 

                 result := GPSTable[i]; 

  else 

  end; 

end; 

function LookupCode(idx:integer;TagType:integer=ExifTag):string; overload; 

var i:integer; 

begin 

  result := ''; 

  case tagType of 

    ThumbTag, 

    ExifTag: for i := 0 to ExifTagCnt do 

               if TagTable[i].Tag = idx then 

                 result := TagTable[i].Code; 

     GpsTag: for i := 0 to GPSCnt do 

               if GPSTable[i].Tag = idx then 

                 result := GPSTable[i].Code; 

  else 

  end; 

end; 

function LookupCode(idx:integer;TagTbl:array of TTagEntry):string; overload; 

var i:integer; 

begin 

  result := ''; 

  for i := 0 to high(TagTbl) do 

    if TagTbl[i].Tag = idx then 

      result := TagTbl[i].Code; 

end; 

// Careful : this function's arguments are always 

// evaluated which may have unintended side-effects 

// (thanks to Jan Derk for pointing this out) 

function siif( const cond:boolean; const s1:string; const s2:string=''):string; 

begin 

  if cond 

    then result := s1 

    else result := s2; 

end; 

procedure TImageInfo.Assign(Source: TImageInfo); 

begin 

  CameraMake      := Source.CameraMake; 

  CameraModel     := Source.CameraModel; 

  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; 

const BadVal = -1; 

function TImageInfo.ExifDateToDateTime(dstr:string):TDateTime; 

type 

  TConvert= packed record 

     year: Array [1..4] of char; f1:char; 

     mon:  Array [1..2] of Char; f2:char; 

     day:  Array [1..2] of Char; f3:char; 

     hr:   Array [1..2] of Char; f4:char; 

     min:  Array [1..2] of Char; f5:char; 

     sec:  Array [1..2] of Char; 

  end; 

  PConvert= ^TConvert; 

begin 

   try 

     with PConvert( @dstr[1] )^ do 

       Result := EncodeDate( StrToInt( year ), 

                             StrToInt( mon ), 

                             StrToInt( day )) 

              +  EncodeTime( StrToInt( hr  ), 

                             StrToInt( min ), 

                             StrToInt( sec ), 0); 

   except 

     result := 0; 

   end; 

end; 

function TImageInfo.ExtrDateTime(oset:integer):TDateTime; 

var tmpStr:string; 

begin 

  tmpStr := copy(parent.exifSegment^.data,oset,19); 

  result := ExifDateToDateTime(tmpStr); 

end; 

//  2001:01:09 16:17:32 

Procedure TImageInfo.SetDateTimeStr(oset:integer; TimeIn:TDateTime); 

var tmp:string; 

  i:integer; 

begin 

  tmp := FormatDateTime('yyyy:mm:dd hh:nn:ss',TimeIn); 

  for i := 1 to length(tmp) do 

    parent.ExifSegment^.data[oset+i-1] := tmp[i]; 

end; 

function TImageInfo.GetImgDateTime:TDateTime; 

var x: TDateTime; 

begin 

  x := 0.0; 

  if dt_oset > 0 then 

    x := ExtrDateTime(dt_oset) 

  else if dt_orig_oset > 0 then 

    x := ExtrDateTime(dt_orig_oset) 

  else if dt_digi_oset > 0 then 

    x := ExtrDateTime(dt_digi_oset); 

  result := x; 

end; 

Procedure TImageInfo.AdjDateTime(days,hours,mins,secs:integer); 

var delta:double; 

    x: TDateTime; 

begin 

  //                hrs/day     min/day        sec/day 

  delta := days + (hours/24)+ (mins/1440) + (secs/86400); 

  if dt_oset > 0 then 

  begin 

    x := ExtrDateTime(dt_oset); 

    SetDateTimeStr(dt_oset,x+delta); 

  end; 

  if dt_orig_oset > 0 then 

  begin 

    x := ExtrDateTime(dt_orig_oset); 

    SetDateTimeStr(dt_orig_oset,x+delta); 

  end; 

  if dt_digi_oset > 0 then 

  begin 

    x := ExtrDateTime(dt_digi_oset); 

    SetDateTimeStr(dt_digi_oset,x+delta); 

  end; 

end; 

Procedure TImageInfo.OverwriteDateTime(InTime:tdatetime); 

begin 

  if dt_oset > 0 then 

    SetDateTimeStr(dt_oset,InTime); 

  if dt_orig_oset > 0 then 

    SetDateTimeStr(dt_orig_oset,InTime); 

  if dt_digi_oset > 0 then 

    SetDateTimeStr(dt_digi_oset,InTime); 

end; 

Function CvtTime(instr:string) :string; 

var i,sl:integer; 

    tb:string; 

    tHours,tMin,tSec:double; 

begin 

   sl := length(DexifDataSep); 

   result := instr;                   // if error return input string 

   i := pos(DexifDataSep,instr); 

   tb    := copy(instr,1,i-1);        // get first irrational number 

   tHours := CvtIrrational(tb);       // bottom of lens speed range 

   instr := copy(instr,i+sl-1,64); 

   i := pos(DexifDataSep,instr); 

   tb    := copy(instr,1,i-1);        // get second irrational number 

   tMin := CvtIrrational(tb);     // minimum focal length 

   instr := copy(instr,i+1,64); 

   tSec := CvtIrrational(instr);  // maximum focal length 

   // Ok we'll send the result back as Degrees with 

   // Decimal Minutes.  Alternatively send back as Degree 

   // Minutes, Seconds or Decimal Degrees. 

   result := format('%0.0f:%0.0f:%0.0f', [tHours,tMin,tSec]); 

end; 

Function GenCompConfig(instr:string) :string; 

var i,ti:integer; 

    ts:string; 

begin 

  ts := ''; 

  for i := 1+1 to 4+1 do  // skip first char... 

  begin 

    ti := integer(instr[i]); 

    case ti of 

      1: ts := ts+'Y'; 

      2: ts := ts+'Cb'; 

      3: ts := ts+'Cr'; 

      4: ts := ts+'R'; 

      5: ts := ts+'G'; 

      6: ts := ts+'B'; 

    else 

    end; 

  end; 

  result := ts; 

end; 

Function GpsPosn(instr:string) :string; 

var i,sl:integer; 

    tb:string; 

    gDegree,gMin,gSec:double; 

begin 

   sl := length(DexifDataSep); 

   result := instr;                     // if error return input string 

   i := pos(DexifDataSep,instr); 

   tb    := copy(instr,1,i-1);          // get first irrational number 

   gDegree := CvtIrrational(tb);        // degrees 

   instr := copy(instr,i+sl-1,64); 

   i := pos(DexifDataSep,instr); 

   tb    := copy(instr,1,i-1);          // get second irrational number 

   gMin := CvtIrrational(tb);           // minutes 

   instr := copy(instr,i+sl-1,64); 

   gSec := CvtIrrational(instr);        // seconds 

   if gSec = 0 then  // camera encoded as decimal minutes 

   begin 

     gSec := ((gMin-trunc(gMin))*100);  // seconds as a fraction of degrees 

     gSec := gSec * 0.6;                // convert to seconds 

     gMin := trunc(gMin);               // minutes is whole portion 

   end; 

   // Ok we'll send the result back as Degrees with 

   // Decimal Minutes.  Alternatively send back as Degree 

   // Minutes, Seconds or Decimal Degrees. 

   case GpsFormat of 

      gf_DD: result := 

          format('%1.4f Decimal Degrees',[gDegree + ((gMin + (gSec/60))/60)]); 

      gf_DM: result := 

          format('%0.0f Degrees %1.2f Minutes',[gDegree, gMin + (gsec/60)]); 

     gf_DMS: result := 

          format('%0.0f Degrees %0.0f Minutes %0.0f Seconds', [gDegree,gMin,gSec]); 

   else 

   end; 

end; 

function DecodeField(DecodeStr,idx:string):string; 

var stPos:integer; 

    ts:string; 

begin 

   result := ''; 

   idx := DexifDecodeSep+trim(idx)+':';   // ease parsing 

   decodeStr := DexifDecodeSep+decodeStr+DexifDecodeSep; 

   stPos := pos(idx,DecodeStr); 

   if stPos > 0 then 

   begin 

     ts := copy(DecodeStr,stPos+length(idx),length(decodeStr)); 

     result := copy(ts,1,pos(DexifDecodeSep,ts)-1); 

   end 

end; 

function TImageInfo.AddTagToArray(nextTag:iTag):integer; 

begin 

  if nextTag.tag <> 0 then     // Empty fields are masked out 

  begin 

    if fITagCount >= MaxTag-1 then 

    begin 

      inc(MaxTag,TagArrayGrowth); 

      SetLength(fITagArray,MaxTag); 

    end; 

    fITagArray[fITagCount] := nextTag; 

    inc(fITagCount); 

  end; 

  result := fITagCount-1; 

end; 

function TImageInfo.AddTagToThumbArray(nextTag: iTag): integer; 

begin 

  if nextTag.tag <> 0 then     // Empty fields are masked out 

  begin 

    if fIThumbCount >= MaxThumbTag-1 then 

    begin 

      inc(MaxThumbTag,TagArrayGrowth); 

      SetLength(fIThumbArray,MaxThumbTag); 

    end; 

    fIThumbArray[fIThumbCount] := nextTag; 

    inc(fIThumbCount); 

  end; 

  result := fIThumbCount-1; 

end; 

function TImageInfo.CvtInt(buff:string):longint; 

var i:integer; 

    r:Int64; 

begin 

  r := 0; 

  try 

  if MotorolaOrder then 

    for i := 1 to length(buff) do 

      r := r*256+ord(buff[i]) 

  else 

    for i := length(buff) downto 1 do 

      r := r*256+ord(buff[i]); 

  except 

  end; 

  result := longint(r); 

end; 

function TImageInfo.FormatNumber(buffer:string;fmt:integer; 

    fmtStr:string;decodeStr:string=''):string; 

var buff2,os:string; 

    i,vlen:integer; 

    tmp,tmp2:longint; 

    dv:double; 

begin 

  os := ''; 

  vlen := BytesPerFormat[fmt]; 

  if vlen = 0 then 

  begin 

    result := '0'; 

    exit; 

  end; 

  for i := 0 to min((length(buffer) div vlen),8)-1 do 

  begin 

    if os <> '' then 

      os := os+DexifDataSep;  // Used for data display 

    buff2 := copy(buffer,(i*vlen)+1,vlen); 

    case fmt of 

      FMT_SBYTE, 

      FMT_BYTE, 

      FMT_USHORT, 

      FMT_ULONG, 

      FMT_SSHORT, 

      FMT_SLONG:     begin 

                       tmp := CvtInt(buff2); 

                       if (decodeStr = '') or not DexifDecode then 

                         os := os + defIntFmt(tmp) // IntToStr(tmp) 

                       else 

                         os := os + DecodeField(decodeStr,IntToStr(tmp)); //+ 

//                           ' ('+IntToStr(tmp)+')'; 

                     end; 

      FMT_URATIONAL, 

      FMT_SRATIONAL: begin 

                       tmp := CvtInt(copy(buff2,1,4)); 

                       tmp2 := CvtInt(copy(buff2,5,4)); 

                       os := os + defFracFmt(tmp,tmp2); //format('%d/%d',[tmp,tmp2]); 

                       if (decodeStr <> '') or not DexifDecode then 

                         os := os + DecodeField(decodeStr,os); // +' ('+os+')'; 

                     end; 

      FMT_SINGLE, 

      FMT_DOUBLE:    begin                       // not used anyway 

                       os := os+ '-9999.99';     // not sure how to 

                     end;                        // interpret endian issues 

    else 

      os := os + '?'; 

    end; 

  end; 

  if fmtStr <> '' then 

  begin 

    if pos('%s', fmtStr) > 0 then 

    begin 

      os := format(fmtStr,[os]); 

    end 

    else 

    begin 

      dv := GetNumber(buffer,fmt); 

      os := format(fmtStr,[dv]); 

    end; 

  end; 

  result := os; 

end; 

function TImageInfo.GetNumber(buffer:string;fmt:integer):double; 

var os:double; 

    tmp:longint; 

    dbl:double absolute tmp; 

    tmp2:longint; 

begin 

  try 

    case fmt of 

      FMT_SBYTE, 

      FMT_BYTE, 

      FMT_USHORT, 

      FMT_ULONG, 

      FMT_SSHORT, 

      FMT_SLONG:  os := CvtInt(buffer); 

      FMT_URATIONAL, 

      FMT_SRATIONAL: begin 

                       tmp := CvtInt(copy(buffer,1,4)); 

                       tmp2 := CvtInt(copy(buffer,5,4)); 

                       os := tmp / tmp2; 

                     end; 

      FMT_SINGLE: os := dbl; 

      FMT_DOUBLE: os := dbl; 

    else 

      os := 0; 

    end; 

  except 

    os := 0; 

  end; 

  result := os; 

end; 

function MakePrintable(s:string):string; 

var r:string; 

  i:integer; 

begin 

  for i := 1 to min(length(s),50) do 

    if not (ord(s[i]) in [32..255]) then 

      r := r+'.' 

    else 

      r := r+s[i]; 

  result := r; 

end; 

function MakeHex(s:string):string; 

var r:string; 

  i:integer; 

begin 

  for i := 1 to min(length(s),16) do 

    r := r+IntToHex(ord(s[i]),2)+' '; 

  if length(s) > 16 then 

    r := r+'...'; 

  result := r; 

end; 

//-------------------------------------------------------------------------- 

// Process one of the nested EXIF directories. 

//-------------------------------------------------------------------------- 

procedure  TImageInfo.ProcessExifDir(DirStart, OffsetBase, ExifLength: longint; 

  tagType:integer = ExifTag; prefix:string=''); 

var ByteCount:integer; 

  tag,TFormat,components:integer; 

  de,DirEntry,OffsetVal,NumDirEntries,ValuePtr,subDirStart:Longint; 

  RawStr,Fstr,transStr:string; 

  msInfo: tmsInfo; 

  lookupE, newE: TTagEntry; 

  tmpTR:string; 

begin 

  NumDirEntries := Get16u(DirStart); 

  if (ExifTrace > 0) then 

    TraceStr := TraceStr +#13#10+ 

      format('Directory: Start, entries = %d, %d',[DirStart, NumDirEntries]); 

  if (DirStart+2+(NumDirEntries*12)) > (DirStart+OffsetBase+ExifLength) then 

  begin 

    Parent.ErrStr := 'Illegally sized directory'; 

    exit; 

  end; 

//Parent.ErrStr:= 

//format('%d,%d,%d,%d+%s',[DirStart,NumDirEntries,OffsetBase,ExifLength, 

//parent.errstr]); 

//  Uncomment to trace directory structure 

  if (tagType = ExifTag) and (ThumbStart = 0) and not TiffFmt then 

  begin 

    DirEntry := DirStart+2+12*NumDirEntries; 

    ThumbStart := Get32u(DirEntry); 

    ThumbLength := OffsetBase+ExifLength-ThumbStart; 

  end; 

  for de := 0 to NumDirEntries-1 do 

  begin 

    DirEntry := DirStart+2+12*de; 

    Tag := Get16u(DirEntry); 

    TFormat := Get16u(DirEntry+2); 

    Components := Get32u(DirEntry+4); 

    ByteCount := Components * BytesPerFormat[TFormat]; 

    if ByteCount = 0 then 

      continue; 

    If ByteCount > 4 then 

    begin 

      OffsetVal := Get32u(DirEntry+8); 

      ValuePtr := OffsetBase+OffsetVal; 

    end 

    else 

      ValuePtr := DirEntry+8; 

    RawStr := copy(parent.EXIFsegment^.data,ValuePtr,ByteCount); 

    fstr := ''; 

    if BuildList in [GenString,GenAll] then 

    begin 

      LookUpE := FetchTagByID(tag,tagType); 

      with LookUpE do 

      begin 

        case tformat of 

          FMT_UNDEFINED: fStr := '"'+StrBefore(RawStr,#0)+'"'; 

             FMT_STRING: fStr := copy(parent.EXIFsegment^.data, 

               ValuePtr,ByteCount-1); 

        else 

          fStr := FormatNumber(RawStr, TFormat, FormatS, Code); 

        end; 

        if (Tag > 0) and assigned(callback) and DexifDecode then 

          fstr := Callback(fStr) 

        else 

          fstr := MakePrintable(fstr); 

        transStr := Desc; 

      end; 

     Case tag of 

       TAG_USERCOMMENT: 

         begin 

           // here we strip off comment header 

           Comments := trim(copy(RawStr,9,ByteCount-9)); 

           fStr := Comments;  // old one is erroneous 

           CommentPosn := ValuePtr; 

           CommentSize := ByteCount-9; 

         end; 

       else 

       end; 

     tmpTR := #13#10+ 

          siif(ExifTrace > 0,'tag[$'+inttohex(tag,4)+']: ','')+ 

          transStr+DexifDelim+fstr+ 

          siif(ExifTrace > 0,' [size: '+inttostr(ByteCount)+']','')+ 

          siif(ExifTrace > 0,' [start: '+inttostr(ValuePtr)+']',''); 

      if tagType = ThumbTag 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 

             SubdirStart := OffsetBase + LongInt(Get32u(ValuePtr)); 

             ProcessExifDir(SubdirStart, OffsetBase, ExifLength, ExifTag); 

           except 

           end; 

         end; 

       TAG_GPS_OFFSET: 

         begin 

           try 

             SubdirStart := OffsetBase + LongInt(Get32u(ValuePtr)); 

             ProcessExifDir(SubdirStart, OffsetBase, ExifLength, GpsTag); 

           except 

           end; 

         end; 

       TAG_MAKE: CameraMake := fstr; 

       TAG_MODEL: CameraModel := fstr; 

       TAG_EXIFVER: ExifVersion := rawstr; 

       TAG_DATETIME: 

         begin 

           dt_oset := ValuePtr; 

           DateTime := fstr; 

         end; 

       TAG_DATETIME_ORIGINAL: 

         begin 

           dt_orig_oset := ValuePtr; 

           DateTime := fstr; 

         end; 

       TAG_DATETIME_DIGITIZED: 

         begin 

           dt_digi_oset := ValuePtr; 

         end; 

       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, TFormat)); 

       TAG_IMAGELENGTH, 

       TAG_EXIF_IMAGELENGTH: 

           begin 

             HPosn := DirEntry+8; 

             Height := round(getNumber(RawStr, TFormat)); 

           end; 

       TAG_IMAGEWIDTH, 

       TAG_EXIF_IMAGEWIDTH: 

           begin 

             WPosn := DirEntry+8; 

             Width := round(getNumber(RawStr, TFormat)); 

           end; 

       TAG_THUMBTYPE: 

           if tagType = ThumbTag then 

             ThumbType := round(getNumber(RawStr, TFormat)); 

     else 

       // no special processing 

     end; 

      if BuildList in [GenList,GenAll] then 

      begin 

        try 

          NewE := LookupE; 

          NewE.Data := fstr; 

          NewE.Raw := RawStr; 

          NewE.Size := length(RawStr); 

          NewE.PRaw := ValuePtr; 

          NewE.TType := tFormat; 

          if tagType = ThumbTag then 

            AddTagToThumbArray(NewE) 

          else 

            AddTagToArray(NewE); 

        except 

          // if we're here: unknown tag. 

          // item is recorded in trace string 

        end; 

    end; 

  end; 

end; 

Procedure TImageInfo.AddMSTag(fname,fstr:string;fType:word); 

var  {lookupE,} newE: TTagEntry; 

begin 

  if BuildList in [GenList,GenAll] then 

  begin 

    try 

      newE.Name := fname; 

      newE.Desc := fname; 

      NewE.Data := fstr; 

      NewE.Raw := fStr; 

      NewE.Size := length(fStr); 

      NewE.PRaw := 0; 

      NewE.TType := fType; 

      NewE.TID := 1; // MsSpecific 

      AddTagToArray(NewE); 

    except 

      // if we're here: unknown tag. 

      // item is recorded in trace string 

    end; 

  end; 

end; 

Procedure TImageInfo.ProcessThumbnail; 

var start:integer; 

begin 

  start := ThumbStart+9; 

  ProcessExifDir(start, 9, ThumbLength-12,ThumbTag,'Thumbnail'); 

end; 

Procedure TImageInfo.removeThumbnail; 

var newSize:integer; 

begin 

  newSize := ThumbStart-6; 

  with parent do 

  begin 

    SetLength(ExifSegment^.data,newSize); 

    ExifSegment^.size := newSize; 

  // size calculations should really be moved to save routine 

    ExifSegment^.data[1] := char(newSize div 256); 

    ExifSegment^.data[2] := char(newSize mod 256); 

  end; 

end; 

procedure TImageInfo.ProcessHWSpecific(MakerBuff:string; 

                TagTbl:Array of TTagEntry; 

                DirStart:longint; 

                MakerOffset:Longint; 

                spOffset:integer = 0); 

var NumDirEntries:integer; 

    de,ByteCount,TagID:integer; 

    DirEntry,tag,TFormat,components:integer; 

    OffsetVal,ValuePtr:Longint; 

    RawStr,Fstr,Fstr2,TagStr,ds:string; 

    OffsetBase: longint; 

    NewE:TTagEntry; 

begin 

  DirStart := DirStart+1; 

  OffsetBase := DirStart-MakerOffset+1; 

  SetDataBuff(MakerBuff); 

  try 

    NumDirEntries := Get16u(DirStart); 

    for de := 0 to NumDirEntries-1 do 

    begin 

      DirEntry := DirStart+2+12*de; 

      Tag := Get16u(DirEntry); 

      TFormat := Get16u(DirEntry+2); 

      Components := Get32u(DirEntry+4); 

      ByteCount := Components * BytesPerFormat[TFormat]; 

      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(MakerBuff) then 

        RawStr := copy(parent.DataBuff,OffsetVal+spOffset,ByteCount) 

      else 

        RawStr := copy(MakerBuff,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 tformat of 

           FMT_STRING: fStr := '"'+strbefore(RawStr,#0)+'"'; 

        FMT_UNDEFINED: fStr := '"'+RawStr+'"'; 

//         FMT_STRING: fStr := '"'+copy(MakerBuff,ValuePtr,ByteCount-1)+'"'; 

      else 

        try 

          ds := siif(dEXIFdecode, LookupCode(tag,TagTbl),''); 

          if TagID < 0 

            then fStr := FormatNumber(RawStr, TFormat, '', '') 

            else fStr := FormatNumber(RawStr, TFormat, TagTbl[TagID].FormatS, ds); 

        except 

          fStr := '"'+RawStr+'"'; 

        end; 

      end; 

      rawDefered := false; 

      if (TagID > 0) and assigned(TagTbl[TagID].CallBack) and DexifDecode then 

        fstr2 := TagTbl[TagID].CallBack(fstr) 

      else 

        fstr2 := MakePrintable(fstr); 

      if (ExifTrace > 0) then 

      begin 

        if not rawDefered then 

          msTraceStr := msTraceStr +#13#10+ 

            'tag[$'+inttohex(tag,4)+']: '+ 

           TagStr+DexifDelim+fstr2+ 

           ' [size: '+inttostr(ByteCount)+']'+ 

           ' [raw: '+MakeHex(RawStr)+']'+ 

           ' [start: '+inttostr(ValuePtr)+']' 

        else 

          msTraceStr := msTraceStr +#13#10+ 

            '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 +#13#10+ 

            TagStr+DexifDelim+fstr2 

        else 

          msTraceStr := msTraceStr+ 

            fstr2+ // has cr/lf as first element 

            #13#10+TagStr+DexifDelim+fstr; 

      end; 

      (* 

      msTraceStr := msTraceStr +#13#10+ 

         siif(ExifTrace > 0,'tag[$'+inttohex(tag,4)+']: ','')+ 

         TagStr+DexifDelim+fstr+ 

         siif(ExifTrace > 0,' [size: '+inttostr(ByteCount)+']','')+ 

         siif(ExifTrace > 0,' [raw: '+MakeHex(RawStr)+']','')+ 

         siif(ExifTrace > 0,' [start: '+inttostr(ValuePtr)+']',''); 

      *) 

    end; 

      if (BuildList in [GenList,GenAll]) and (TagID > 0) then 

      begin 

        try 

          NewE := TagTbl[TagID]; 

          NewE.Data := fstr; 

          NewE.Raw := RawStr; 

          NewE.TType := tFormat; 

          NewE.TID := 1; // MsSpecific 

          AddTagToArray(NewE); 

        except 

          // if we're here: unknown tag. 

          // item is recorded in trace string 

        end; 

      end; 

     end; 

  except 

     on e:exception do 

       Parent.ErrStr := 'Error Detected = '+e.message; 

   end; 

   SetDataBuff(parent.DataBuff); 

end; 

Function ExtractComment(instr: string): string; 

begin 

//  CommentHeader := copy(instr,1,8);  // fixed length string 

  result := copy(instr,9,maxint); 

end; 

Function FlashCallBack(instr: string): string; 

var tmp: integer; 

    tmpS: string; 

begin 

  tmp := strToInt(instr); 

  tmps :=      siif(tmp and  1 =  1,'On','Off');             // bit0 

  tmps := tmps+siif(tmp and  6 =  2,', UNKNOWN');             // bit1 

  tmps := tmps+siif(tmp and  6 =  4,', no strobe return');    // bit2 

  tmps := tmps+siif(tmp and  6 =  6,', strobe return');       // bit1+2 

  tmps := tmps+siif(tmp and 24 =  8,', forced');              // bit3 

  tmps := tmps+siif(tmp and 24 = 16,', surpressed');          // bit4 

  tmps := tmps+siif(tmp and 24 = 24,', auto mode');           // bit3+4 

  tmps := tmps+siif(tmp and 32 = 32,', no flash function');  // bit5 

  tmps := tmps+siif(tmp and 64 = 64,', red-eye reduction');  // bit6 

  result := tmps; 

end; 

function ExposCallBack(instr: string):string; 

var expoTime:double; 

begin 

  expoTime := strToFloat(instr); 

  result := Format('%4.4f sec',[expoTime])+ 

    siif(ExpoTime <= 0.5, 

      format(' (1/%d)',[round(1/ExpoTime)]),''); 

// corrected by M. Schwaiger - adding ".5" is senseless when using "round"! 

end; 

function SSpeedCallBack(instr: string):string; 

var expoTime:double; 

begin 

  expoTime := CvtIrrational(instr); 

  expoTime := (1/exp(expoTime*ln(2))); 

  result := Format('%4.4f sec',[expoTime])+ 

    siif(ExpoTime <= 0.5, 

      format(' (1/%d)',[round(1/ExpoTime)]),''); 

end; 

function xpTranslate(instr: string):string; 

var i:integer; 

    ts:string; 

    cv:char; 

begin 

  ts := ''; 

  for i := 1 to StrCount(instr,',') do 

    if odd(i) then 

    begin 

       cv := chr(strtoint(StrNth(instr,',',i))); 

       if cv <> #0 then 

         ts := ts+cv; 

    end; 

  result := ts; 

end; 

function TImageInfo.toLongString: string; 

var tmpStr:string; 

begin 

  if parent.ExifSegment = nil then 

    result := '' 

  else if Parent.errstr <> '<none>' then 

    result := 'File Name: '  + ExtractFileName(parent.Filename) + crlf + 

            'Exif Error: '+Parent.errstr 

  else 

  begin 

    result := 'File Name: '   + ExtractFileName(parent.Filename) + crlf + 

            'File Size: '   + IntToStr(parent.FileSize div 1024)+ 'k'   + crlf + 

            'File Date: '   + dateToStr(parent.FileDateTime)   + crlf + 

            'Photo Date: '  + DateTime + crlf + 

            'Make (Model): '  + CameraMake + ' ('+CameraModel+')' + crlf + 

            'Dimensions: '  + IntToStr(Width) + ' x '+ 

                              IntToStr(Height); 

    if BuildList in [GenString,GenAll] then 

    begin 

      tmpStr := LookupTagVal('ExposureTime'); 

      if tmpStr <> '' then 

        result := result+crlf+'Exposure Time: '+tmpStr 

      else 

      begin 

        tmpStr := LookupTagVal('ShutterSpeedValue'); 

        if tmpStr <> '' then 

          result := result+crlf+'Exposure Time: '+tmpStr 

      end; 

      tmpStr := LookupTagVal('FocalLength'); 

      if tmpStr <> '' then 

        result := result+crlf+'Focal Length: '+tmpStr; 

      tmpStr := LookupTagVal('FocalLengthin35mm'); 

      if tmpStr <> '' then 

        result := result+crlf+'Focal Length (35mm): '+tmpStr; 

      tmpStr := LookupTagVal('FNumber'); 

      if tmpStr <> '' then 

        result := result+crlf+'FNumber: '+tmpStr; 

      tmpStr := LookupTagVal('ISOSpeedRatings'); 

      if tmpStr <> '' then 

        result := result+crlf+'ISO: '+tmpStr; 

    end; 

    result := result + crlf + 

      'Flash: ' + siif(odd(FlashUsed),'Yes','No'); 

  end; 

end; 

function TImageInfo.toString: string; 

begin 

  if parent.ExifSegment = nil then 

    result := '' 

  else if Parent.errstr <> '<none>' then 

    result := ExtractFileName(parent.Filename) + ' Exif Error: '+Parent.errstr 

  else 

    result := ExtractFileName(parent.Filename) + ' ' + 

            IntToStr(parent.FileSize div 1024)+'k '+ 

            Copy(DateTime,1,10) + ' '+ 

            IntToStr(Width)+'w '+IntToStr(Height)+'h ' 

            +siif(odd(FlashUsed),' Flash',''); 

end; 

(************************************************* 

The following methods write data back into the 

EXIF buffer. 

*************************************************) 

procedure TImageInfo.SetExifComment( newComment:string); 

begin 

  WriteThruString('UserComment','ASCII'#0#0#0+newComment); 

end; 

procedure TImageInfo.AdjExifSize(nh,nw:longint); 

begin 

  if (Height <=0) or (Width <=0) then 

    exit; 

  if (nw <> Width) or (nh <> Height) then 

  begin 

    parent.WriteInt32(parent.ExifSegment^.data,nh,hPosn); 

    parent.WriteInt32(parent.ExifSegment^.data,nw,wPosn); 

  end; 

end; 

procedure TImageInfo.TagWriteThru16(te:ttagentry;NewVal16:word); 

begin 

  parent.WriteInt16(parent.ExifSegment^.data,newVal16,te.praw); 

end; 

procedure TImageInfo.TagWriteThru32(te:ttagentry;NewVal32:longint); 

begin 

  parent.WriteInt16(parent.ExifSegment^.data,newVal32,te.praw); 

end; 

function TImageInfo.WriteThruInt(tname:string;value:longint):boolean; 

var te:ttagentry; 

  vlen:integer; 

begin 

  result := false;  // failure 

  te := Data[tname]; 

  if te.Tag = 0 then 

    exit; 

   result := true;   // success 

   vlen := BytesPerFormat[te.TType]; 

   if vlen = 2 then 

     TagWriteThru16(te,word(value)) 

   else 

   if vlen = 4 then 

     TagWriteThru32(te,value) 

   else 

     result := false;    // don't recognize the type 

end; 

function TImageInfo.WriteThruString(tname:string;value:String):boolean; 

var te:ttagentry; 

  i,sPosition:integer; 

begin 

  result := false;  // failure 

  te := Data[tname]; 

  if te.Tag = 0 then 

    exit; 

  with parent.ExifSegment^ do 

  begin 

    sPosition := te.PRaw; 

    for i := 0 to te.Size-2 do 

      if i > length(value)-1 then 

        data[i+sPosition] := #0 

      else 

        data[i+sPosition] := value[i+1]; 

    data[te.Size-1] := #0; // strings are null terminated 

  end; 

  result := true;   // success 

end; 

// 

//   Sample call  - 

//        ImgData.ExifObj.WriteThruInt('Orientation',3); 

// 

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

constructor TImageInfo.Create(p: timgdata; buildCode: integer = GenAll); 

begin 

  inherited create; 

  LoadTagDescs(True);  // initialize global structures 

  FITagCount := 0; 

  buildList := BuildCode; 

  parent := p; 

end; 

constructor TImgData.Create(buildCode: integer = GenAll); 

begin 

  inherited create; 

  buildList := BuildCode; 

  reset; 

end; 

function TImageInfo.GetTagElement(TagID: integer): TTagEntry; 

begin 

  result := fITagArray[TagID] 

end; 

procedure TImageInfo.SetTagElement(TagID: integer; 

  const Value: TTagEntry); 

begin 

  fITagArray[TagID] := Value; 

end; 

function TImageInfo.GetTagByName(TagName: string): TTagEntry; 

var i:integer; 

begin 

  i := LookupTag(TagName); 

  if i >= 0 then 

    result := fITagArray[i] 

  else 

    result := EmptyEntry; 

end; 

procedure TImageInfo.SetTagByName(TagName: string; const Value: TTagEntry); 

var i:integer; 

begin 

  i := LookupTag(TagName); 

  if i >= 0 then 

    fITagArray[i] := Value 

  else 

  begin 

    AddTagToArray(value); 

  end; 

end; 

function TImageInfo.IterateFoundTags(TagId: integer; 

        var retVal:TTagEntry):boolean; 

begin 

  FillChar(retVal,sizeof(retVal),0); 

  while (iterator < FITagCount) and (FITagArray[iterator].TID <> TagId) do 

    inc(iterator); 

  if (iterator < FITagCount) then 

  begin 

    retVal := FITagArray[iterator]; 

    inc(iterator); 

    result := true; 

  end 

  else 

    result := false; 

end; 

procedure TImageInfo.ResetIterator; 

begin 

   iterator := 0; 

end; 

function TImageInfo.IterateFoundThumbTags(TagId: integer; 

        var retVal:TTagEntry):boolean; 

begin 

  FillChar(retVal,sizeof(retVal),0); 

  while (iterThumb < FIThumbCount) and (FITagArray[iterThumb].TID <> TagId) do 

    inc(iterThumb); 

  if (iterThumb < FIThumbCount) then 

  begin 

    retVal := FIThumbArray[iterThumb]; 

    inc(iterThumb); 

    result := true; 

  end 

  else 

    result := false; 

end; 

procedure TImageInfo.ResetThumbIterator; 

begin 

   iterThumb := 0; 

end; 

function TImageInfo.GetRawFloat( tagName: string ):double; 

var tiq :TTagEntry; 

begin 

  tiq := GetTagByName( tagName ); 

  if tiq.Tag = 0 // EmptyEntry 

    then result := 0.0 

    else result := GetNumber(tiq.Raw, tiq.TType); 

end; 

function TImageInfo.GetRawInt( tagName: string ):integer; 

begin 

  result := round(GetRawFloat(tagName)); 

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  := copy(uppercase(cameramake),1,5); 

  upModel := copy(uppercase(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; 

begin 

  if LookUpTag('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 

    CCDWidth := Width * fpu / tmp; 

  tmp := GetRawInt('FocalPlaneYResolution'); 

  if (tmp > 0) then 

    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; 

// now load it into the tag array 

    tmp := LookupTagDefn('FocalLengthIn35mmFilm'); 

    LookUpE := TagTable[tmp]; 

    NewE := LookupE; 

    NewE.Data := Format('%5.2f',[fl35]); 

    NewE.Raw := ''; 

    NewE.FormatS := '%s mm'; 

    NewE.TType := FMT_SRATIONAL; 

    AddTagToArray(NewE); 

    TraceStr := TraceStr+#13#10+ 

          siif(ExifTrace > 0,'tag[$'+inttohex(tmp,4)+']: ','')+ 

          NewE.Desc+DexifDelim+NewE.Data+ 

          siif(ExifTrace > 0,' [size: 0]','')+ 

          siif(ExifTrace > 0,' [start: 0]',''); 

end; 

function TImageInfo.EXIFArrayToXML: tstringlist; 

var buff:tstringlist; 

  i:integer; 

begin 

  buff := TStringList.Create; 

  buff.add('   <EXIFdata>'); 

  for i := 0 to fiTagCount-1 do 

    with fITagArray[i] do 

    begin 

      buff.add('   <'+name+'>'); 

      if tag in [105,120] // headline and image caption 

        then buff.add('      <![CDATA['+data+']]>') 

        else buff.add('      '+data); 

      buff.add('   </'+name+'>'); 

    end; 

  buff.add('   </EXIFdata>'); 

  result := buff; 

end; 

function getbyte( var f : tstream) : byte; 

var a : byte; 

begin 

  f.Read(a,1); 

  result := a; 

end; 

//-------------------------------------------------------------------------- 

// Here we implement the Endian Independent layer.  Outside 

// of these methods we don't care about endian issues. 

//-------------------------------------------------------------------------- 

function tEndInd.GetDataBuff: string; 

begin 

  result := llData; 

end; 

procedure tEndInd.SetDataBuff(const Value: string); 

begin 

  llData := Value; 

end; 

procedure tEndInd.WriteInt16(var buff:string;int,posn:integer); 

begin 

  if MotorolaOrder then 

  begin 

    buff[posn+1] := char(int mod 256); 

    buff[posn] := char(int div 256); 

  end 

  else 

  begin 

    buff[posn] := char(int mod 256); 

    buff[posn+1] := char(int div 256); 

  end 

end; 

procedure tEndInd.WriteInt32(var buff:string;int,posn:longint); 

begin 

  if MotorolaOrder then 

  begin 

    buff[posn+3] := char(int mod 256); 

    buff[posn+2] := char((int shr 8) mod 256); 

    buff[posn+1] := char((int shr 16) mod  256); 

    buff[posn]   := char((int shr 24) mod 256); 

  end 

  else 

  begin 

    buff[posn] := char(int mod 256); 

    buff[posn+1] := char((int shr 8) mod 256); 

    buff[posn+2] := char((int shr 16) mod  256); 

    buff[posn+3] := char((int shr 24) mod 256); 

  end 

end; 

//-------------------------------------------------------------------------- 

// Convert a 16 bit unsigned value from file's native byte order 

//-------------------------------------------------------------------------- 

function tEndInd.Get16u(oset: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(llData[oset]) shl 8) 

           or byte(llData[oset+1]) 

    else result := (byte(llData[oset+1]) shl 8) 

           or byte(llData[oset]); 

end; 

//-------------------------------------------------------------------------- 

// Convert a 32 bit signed value from file's native byte order 

//-------------------------------------------------------------------------- 

function tEndInd.Get32s(oset:integer):Longint; 

begin 

  if MotorolaOrder 

    then result := (byte(llData[oset]) shl 24) 

           or (byte(llData[oset+1]) shl 16) 

           or (byte(llData[oset+2]) shl 8) 

           or byte(llData[oset+3]) 

    else result := (byte(llData[oset+3]) shl 24) 

           or (byte(llData[oset+2]) shl 16) 

           or (byte(llData[oset+1]) shl 8) 

           or byte(llData[oset]); 

end; 

//-------------------------------------------------------------------------- 

// Convert a 32 bit unsigned value from file's native byte order 

//-------------------------------------------------------------------------- 

function tEndInd.Put32s(data:Longint):string; 

var  data2:integer; 

     buffer:string[4] absolute data2; 

     bbuff:char; 

begin 

  data2 := data; 

  if MotorolaOrder then 

  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(oset:integer):Longword; 

begin 

  result := Longword(Get32S(oset)) and $FFFFFFFF; 

end; 

//-------------------------------------------------------------------------- 

// The following methods implement the outer parser which 

// decodes the segments.  Further parsing isthen passed on to 

// the TImageInfo (for EXIF) and TIPTCData objects 

//-------------------------------------------------------------------------- 

Procedure TImgData.MakeIPTCSegment(buff:string); 

var bl:integer; 

begin 

  bl := length(buff)+2; 

  if IPTCSegment = nil then 

  begin 

    inc(SectionCnt); 

    IPTCSegment := @(sections[SectionCnt]); 

  end; 

  IPTCSegment^.data := char(bl div 256)+char(bl mod 256)+buff; 

  IPTCSegment^.size := bl; 

  IPTCSegment^.dtype := M_IPTC; 

end; 

Procedure TImgData.MakeCommentSegment(buff:string); 

var bl:integer; 

begin 

  bl := length(buff)+2; 

  if CommentSegment = nil then 

  begin 

    inc(SectionCnt); 

    CommentSegment := @(sections[SectionCnt]); 

  end; 

  CommentSegment^.data := char(bl div 256)+char(bl mod 256)+buff; 

  CommentSegment^.size := bl; 

  CommentSegment^.dtype := M_COM; 

end; 

Function TImgData.GetCommentSegment:string; 

begin 

  result := ''; 

  if CommentSegment <> nil then 

    result := copy(CommentSegment^.data,2,maxint); 

end; 

function TImgData.SaveExif(var jfs2:tstream):longint; 

var cnt:longint; 

    buff:string; 

begin 

  cnt:=0; 

  buff := #$FF#$D8; 

  jfs2.Write(pointer(buff)^,length(buff)); 

  if ExifSegment <> nil then 

    with ExifSegment^ do 

    begin 

      buff := #$FF+chr(Dtype)+data; 

      cnt := cnt+jfs2.Write(pointer(buff)^,length(buff)); 

    end 

  else 

    if HeaderSegment <> nil then 

      with HeaderSegment^ do 

      begin 

        buff := chr($FF)+chr(Dtype)+data; 

        // buff := #$FF+chr(Dtype)+#$00#$10'JFIF'#$00#$01#$02#$01#$01','#$01','#$00#$00; 

        cnt := cnt+jfs2.Write(pointer(buff)^,length(buff)); 

      end 

    else if (cnt = 0) then 

    begin 

      // buff := chr($FF)+chr(Dtype)+data; 

      buff := #$FF+chr(M_JFIF)+#$00#$10'JFIF'#$00#$01#$02#$01#$01','#$01','#$00#$00; 

      cnt := cnt+jfs2.Write(pointer(buff)^,length(buff)); 

    end; 

  if IPTCSegment <> nil then 

    with IPTCSegment^ do 

    begin 

      buff := chr($FF)+chr(Dtype)+data; 

      cnt := cnt+jfs2.Write(pointer(buff)^,length(buff)); 

    end; 

  if CommentSegment <> nil then 

    with CommentSegment^ do 

    begin 

      buff := chr($FF)+chr(Dtype)+data; 

      cnt := cnt+jfs2.Write(pointer(buff)^,length(buff)); 

    end; 

   result := cnt; 

end; 

function TImgData.ExtractThumbnailBuffer: String; 

var 

  STARTmarker,STOPmarker:integer; 

  tb:string; 

begin 

  result := ''; 

  if HasThumbnail then 

  begin 

    try 

      tb := copy(DataBuff,ExifObj.ThumbStart,ExifObj.ThumbLength); 

      STARTmarker := pos(#$ff#$d8#$ff#$db,tb); 

      if Startmarker = 0 then 

        STARTmarker := pos(#$ff#$d8#$ff#$c4,tb); 

      if STARTmarker <= 0 then 

        exit; 

      tb := copy(tb,STARTmarker,length(tb));  // strip off thumb data block 

      // ok, this is fast and easy - BUT what we really need 

      // is to read the length bytes to do the extraction... 

      STOPmarker := pos(#$ff#$d9,tb)+2; 

      tb := copy(tb,1,STOPmarker); 

      result := tb; 

    except 

    // result will be empty string... 

    end; 

  end; 

end; 

{$IFNDEF dExifNoJpeg} 

function TImgData.ExtractThumbnailJpeg: TJpegImage; 

var ti:TJPEGImage; 

  x:TStringStream; 

  tb:string; 

begin 

  result := nil; 

  if HasThumbnail and (ExifObj.ThumbType = JPEG_COMP_TYPE) then 

  begin 

    tb := ExtractThumbnailBuffer(); 

    if (tb = '') then 

      exit; 

    x := TStringStream.Create(tb); 

    ti := TJPEGImage.Create; 

    x.Seek(0,soFromBeginning); 

    ti.LoadFromStream(x); 

    x.Free; 

    result := ti; 

  end; 

end; 

procedure TImgData.WriteEXIFJpeg(j:tjpegimage;fname:string;origName:string; 

  adjSize:boolean = true); 

begin 

  if origName = '' then 

    origName := fname; 

  if not ReadExifInfo(origName) then 

  begin 

    j.SaveToFile(fname); 

    exit; 

  end; 

  WriteEXIFJpeg(j,fname,adjSize); 

end; 

procedure TImgData.WriteEXIFJpeg(fname:string); 

var img:tjpegimage; 

begin 

  img := TJPEGImage.Create; 

  img.LoadFromFile(Filename); 

  WriteEXIFJpeg(img,fname,false); 

  img.Free; 

end; 

procedure TImgData.WriteEXIFJpeg(j:tjpegimage;fname:string; adjSize:boolean = true); 

var jms:tmemorystream; 

    jfs:TFileStream; 

    pslen:integer; 

    tb:array[0..12] of byte; 

begin 

  pslen := 2; 

  jms := tmemorystream.Create; 

  try  { Thanks to Erik Ludden... } 

    jfs := tfilestream.Create(fname,fmCreate or fmShareExclusive); 

    try 

      if adjSize and (EXIFobj <> nil) then 

        EXIFobj.AdjExifSize(j.height,j.width); 

      SaveExif(tstream(jfs)); 

      j.SaveToStream(jms); 

      jms.Seek(2,soFromBeginning); 

      jms.Read(tb,12);      // a little big to help debug... 

      if tb[1] = M_JFIF then                // strip header 

        pslen := pslen+(tb[2]*256)+tb[3]+2; // size+id bytes 

      jms.Seek(pslen,soFromBeginning); 

      jms.Read(tb,12); 

      if tb[1] = M_EXIF then                // strip exif 

        pslen := pslen+tb[2]*256+tb[3]+2;   // size+id bytes 

      jms.Seek(pslen,soFromBeginning); 

      jms.Read(tb,12); 

      if tb[1] = M_IPTC then                // strip iptc 

        pslen := pslen+tb[2]*256+tb[3]+2;   // size+id bytes 

      jms.Seek(pslen,soFromBeginning); 

      jms.Read(tb,12); 

      if tb[1] = M_COM then                 // strip comment 

        pslen := pslen+tb[2]*256+tb[3]+2;   // size+id bytes 

      jms.Seek(pslen,soFromBeginning); 

      jfs.Seek(0,soFromEnd); 

      jfs.CopyFrom(jms,jms.Size-pslen); 

    finally 

      jfs.Free; 

    end 

  finally 

    jms.Free; 

  end 

end; 

{$ENDIF} 

function TImgData.GetCommentStr:string; 

var buffer:string; 

    bufLen:integer; 

begin 

  buffer := CommentSegment^.Data; 

  bufLen := (byte(buffer[1]) shl 8) or byte(buffer[2]); 

  result := copy(buffer,3,bufLen-2); 

end; 

function TImgData.ReadExifInfo(fname:string):boolean; 

begin 

  ProcessFile(fname); 

  result := HasMetaData(); 

end; 

function TImgData.FillInIptc:boolean; 

begin 

  if IPTCSegment = nil then 

    CreateIPTCObj 

  else 

    IPTCObj.ParseIPTCArray(IPTCSegment^.Data); 

//    filename := FName; 

  result := IPTCObj.HasData(); 

end; 

function TImgData.ProcessFile( const FileName :String):boolean; 

var extn:string; 

begin 

  reset; 

  result := false; 

  if not FileExists(FileName) then 

    exit; 

  SetFileInfo(FileName); 

  try 

      errstr := 'Not an EXIF file'; 

      extn :=  lowercase(ExtractFileExt(filename)); 

      if (extn = '.jpg') or (extn = '.jpeg') or (extn = '.jpe') then 

      begin 

        if not ReadJpegFile(FileName) then 

          exit; 

      end 

      else 

      if (extn = '.tif') or (extn = '.tiff') or (extn = '.nef') then 

      begin 

        if not ReadTiffFile(FileName) then 

          exit; 

      end 

      else 

      begin 

        exit; 

      end; 

      errstr := '<none>'; 

//      msAvailable := ReadMSData(Imageinfo); 

//      msName := gblUCMaker; 

      result := true; 

  except 

    errstr := 'Illegal Exif construction'; 

  end; 

end; 

procedure TImgData.SetFileInfo(fname:string); 

var s:tsearchrec; 

    stat:word; 

begin 

   stat := findfirst(fname,faAnyFile,s); 

   if stat = 0 then 

   begin 

     Filename := fname; 

     FileDateTime := FileDateToDateTime(s.Time); 

     FileSize := s.Size; 

   end; 

   FindClose(s); 

end; 

procedure TImgData.CreateIPTCObj; 

begin 

  MakeIPTCSegment(''); 

  IPTCobj := TIPTCdata.Create(self); 

  // IPTCdata := IPTCobj;  // old style global pointer 

end; 

//-------------------------------------------------------------------------- 

// Parse the marker stream until SOS or EOI is seen; 

//-------------------------------------------------------------------------- 

function TImgData.ReadJpegSections (var f: tstream):boolean; 

var a,b:byte; 

    ll,lh,itemlen,marker:integer; 

begin 

  a := getbyte(f); 

  b := getbyte(f); 

  if (a <> $ff) or (b <> M_SOI) then 

  begin 

    result := FALSE; 

    exit; 

  end; 

  SectionCnt := 0; 

  while SectionCnt < 20 do  // prevent overruns on bad data 

  begin 

    repeat 

      marker := getByte(f); 

    until marker <> $FF; 

    Inc(SectionCnt); 

    // Read the length of the section. 

    lh := getByte(f); 

    ll := getByte(f); 

    itemlen := (lh shl 8) or ll; 

    with Sections[SectionCnt] do 

    begin 

      DType := marker; 

      Size := itemlen; 

      setlength(data,itemlen); 

      data[1] := chr(lh); 

      data[2] := chr(ll); 

      try 

        F.Read(data[3],itemlen-2); 

      except 

        continue; 

      end; 

    end; 

    if (SectionCnt = 5) and not HasMetaData() then 

      break;  // no exif by 8th - let's not waste time 

    case marker of 

      M_SOS: begin 

               break; 

             end; 

      M_EOI: begin  // in case it's a tables-only JPEG stream 

               break; 

             end; 

      M_COM: begin // Comment section 

               CommentSegment := @sections[SectionCnt]; 

             end; 

      M_IPTC: begin // IPTC section 

               if (IPTCSegment = nil) then 

               begin 

                 IPTCSegment := @sections[SectionCnt]; 

                 IPTCobj := TIPTCdata.Create(self); 

                 // IPTCdata := IPTCobj;  // old style global pointer 

               end; 

             end; 

      M_JFIF: begin 

                // Regular jpegs always have this tag, exif images have the exif 

                // marker instead, althogh ACDsee will write images with both markers. 

                // this program will re-create this marker on absence of exif marker. 

               // dec(SectionCnt); 

                HeaderSegment := @sections[SectionCnt]; 

                // break; 

              end; 

      M_EXIF: begin 

                if ((SectionCnt <= 5) and (EXIFsegment = nil) )then 

                begin 

                    // Seen files from some 'U-lead' software with Vivitar scanner 

                    // that uses marker 31 later in the file (no clue what for!) 

                    EXIFsegment := @sections[SectionCnt]; 

                    EXIFobj := TImageInfo.Create(self,BuildList); 

                    EXIFobj.TraceLevel := TraceLevel; 

                    // ImageInfo := EXIFobj;  // old style global pointer 

                    SetDataBuff(EXIFsegment^.data); 

                    ProcessEXIF; 

                end 

                else 

                begin 

                  // Discard this section. 

                  dec(SectionCnt); 

                end; 

              end; 

      M_SOF0..M_SOF15: begin 

                 // process_SOFn(Data, marker); 

             end; 

    else 

      // break; 

    end; 

 end; 

 result := HasMetaData(); 

end; 

function TImgData.ReadJpegFile(const FileName:string):boolean; 

var F: tfilestream; 

begin 

  TiffFmt := false;  // default mode 

  F := TFileStream.Create(filename,fmOpenRead or fmShareDenyWrite); 

  try 

    result := ReadJpegSections(tstream(F)); 

  except 

    result := false; 

  end; 

  F.Free; 

end; 

function TImgData.ReadTiffSections (var f: tstream):boolean; 

var // lh,ll, 

    itemlen:integer; 

    fmt:string; 

begin 

  result := true; 

  fmt := char(getbyte(f))+char(getbyte(f)); 

  if (fmt <> 'II') and (fmt <> 'MM') then 

  begin 

    result := FALSE; 

    exit; 

  end; 

  setlength(Sections[1].data,6); 

  F.Read(Sections[1].data[1],6); 

{ 

  // length calculations are inconsistant for TIFFs 

  lh := byte(Sections[1].data[1]); 

  ll := byte(Sections[1].data[2]); 

  if MotorolaOrder 

    then itemlen := (lh shl 8) or ll 

    else itemlen := (ll shl 8) or lh; 

} 

//  itemlen := (ll shl 8) or lh; 

  itemlen := TiffReadLimit; 

  setlength(Sections[1].data,itemlen); 

  F.Read(Sections[1].data[1],itemlen); 

  SectionCnt := 1; 

  EXIFsegment := @(sections[1]); 

  EXIFobj := TImageInfo.Create(self,BuildList); 

  EXIFobj.TraceLevel := TraceLevel; 

  ExifObj.TiffFmt := TiffFmt; 

  ExifObj.TraceStr := ''; 

  EXIFsegment := @sections[SectionCnt]; 

  ExifObj.DataBuff := Sections[1].data; 

  ExifObj.parent.DataBuff :=  Sections[1].data; 

  ExifObj.MotorolaOrder := fmt = 'MM'; 

  EXIFobj.ProcessExifDir(1, -7 , itemlen); 

  EXIFobj.Calc35Equiv(); 

end; 

function TImgData.ReadTiffFile(const FileName:string):boolean; 

var F: tfilestream; 

begin 

  TiffFmt := true; 

  F := TFileStream.Create(filename,fmOpenRead or fmShareDenyWrite); 

  try 

    result := ReadTiffSections(tstream(F)); 

  except 

    result := false; 

  end; 

  F.Free; 

  TiffFmt := false; 

end; 

Procedure TImgData.ProcessEXIF; 

var hdr:string; 

    toset:integer; 

begin 

  if not assigned(ExifObj) then 

    ExifObj := TImageInfo.Create(self,BuildList); 

  hdr := copy(EXIFsegment^.Data,3,length(validHeader)); 

  if  hdr <> validHeader then 

  begin 

    errStr := 'Incorrect Exif header'; 

    exit; 

  end; 

  if copy(EXIFsegment^.Data,9,2) = 'II' then 

    MotorolaOrder := false 

  else if copy(EXIFsegment^.Data,9,2) = 'MM' then 

    MotorolaOrder := true 

  else 

  begin 

    errStr := 'Invalid Exif alignment marker'; 

    exit; 

  end; 

  ExifObj.TraceStr := ''; 

  ExifObj.DataBuff := DataBuff; 

  ExifObj.MotorolaOrder := MotorolaOrder; 

  toset := Get32u(17-4); 

  if toset = 0 

    then ExifObj.ProcessExifDir(17, 9, EXIFsegment^.Size-6) 

    else ExifObj.ProcessExifDir(9+toset, 9, EXIFsegment^.Size-6); 

  if errstr <> '' then 

  begin 

    EXIFobj.Calc35Equiv(); 

  end; 

end; 

procedure TImgData.Reset; 

begin 

  SectionCnt := 0; 

  ExifSegment := nil; 

  IPTCSegment := nil; 

  CommentSegment := nil; 

  HeaderSegment := nil; 

  Filename := ''; 

  FileDateTime := 0; 

  FileSize := 0; 

  ErrStr := ''; 

  FreeAndNil(ExifObj); 

  FreeAndNil(IptcObj); 

  MotorolaOrder := false; 

end; 

function TImgData.HasMetaData: boolean; 

begin 

  result := (EXIFsegment <> nil) or (CommentSegment <> nil) or 

            (IPTCsegment <> nil); 

end; 

function TImgData.HasEXIF: boolean; 

begin 

  result := (EXIFsegment <> nil); 

end; 

function TImgData.HasThumbnail: boolean; 

begin 

  result := (EXIFsegment <> nil) and EXIFobj.hasThumbnail; 

end; 

function TImgData.HasIPTC: boolean; 

begin 

  result := (IPTCsegment <> nil); 

end; 

function TImgData.HasComment: boolean; 

begin 

  result := (Commentsegment <> nil); 

end; 

function TImageInfo.HasThumbnail: boolean; 

begin 

  // 19 is minimum valid starting position 

  result := (ThumbStart > 21) and (ThumbLength > 256); 

end; 

function TImgData.ReadIPTCStrings(fname: string): tstringlist; 

begin 

  if ProcessFile(fname) and HasIPTC then 

    result := IPTCObj.ParseIPTCStrings(IPTCSegment^.Data) 

  else 

    result := nil; 

end; 

function TImgData.MetaDataToXML: tstringlist; 

var buff,buff2:tstringlist; 

  s:tsearchrec; 

begin 

  if FindFirst(Filename,faAnyFile,s) <> 0 then 

  begin 

    FindClose(s); 

    result := nil; 

    exit; 

  end; 

  buff := TStringList.Create; 

  buff.add('<dImageFile>'); 

  buff.add('   <OSdata>'); 

  buff.add('      <name> '+ExtractFileName(s.Name)+' </name>'); 

  buff.add('      <path> '+ExtractFilePath(Filename)+' </path>'); 

  buff.add('      <size> '+inttostr(s.Size)+' </size>'); 

  buff.add('      <date> '+DateToStr(FileDateToDateTime(s.time))+' </date>'); 

  buff.add('   </OSdata>'); 

  if ExifObj <> nil then 

  begin 

    buff2 := ExifObj.EXIFArrayToXML; 

    if buff2 <> nil then 

    begin 

      buff.AddStrings(buff2); 

      buff2.Clear; 

      buff2.Free; 

    end; 

  end; 

  if IptcObj <> nil then 

  begin 

    buff2 := IptcObj.IPTCArrayToXML; 

    if buff2 <> nil then 

    begin 

      buff.AddStrings(buff2); 

      buff2.Clear; 

      buff2.Free; 

    end; 

  end; 

  buff.add('</dImagefile>'); 

  result := buff; 

end; 

function defIntFmt (inInt:integer):string; 

begin 

  result := IntToStr(inInt) 

end; 

function defRealFmt(inReal:double):string; 

begin 

  result := FloatToStr(inReal); 

end; 

function GCD(a, b : integer):integer; 

begin 

  try 

  if (b mod a) = 0 then 

    Result := a 

  else 

    Result := GCD(b, a mod b); 

  except 

    result := 1 

  end; 

end; 

function fmtRational( num,den:integer):string; 

var 

  gcdVal,intPart,fracPart,newNum,newDen: integer; 

  outStr:String; 

begin 

  // first, find the values 

  gcdVal := GCD(num,den); 

  newNum := num div gcdVal;   // reduce the numerator 

  newDen := den div gcdVal;    //  reduce the denominator 

  intPart := newNum div newDen; 

  fracPart := newNum mod newDen; 

  // now format the string 

  outStr := ''; 

  if intPart <> 0 then 

     outStr := inttostr(intPart)+' '; 

  if fracPart <> 0 then 

       outStr := outStr + inttostr(fracPart)+'/'+inttostr(newDen); 

  result := trim(outstr);  // trim cleans up extra space 

end; 

function defFracFmt(inNum,inDen:integer):string; 

begin 

  result := format('%d/%d',[inNum,inDen]); 

 // result := fmtRational(inNum,inDen); 

 // 

 // It turns out this is not a good idea generally 

 // because some std. calculation use rational 

 // representations internally 

end; 

{$IFDEF dEXIFpredeclare} 

initialization 

  ImgData := TImgData.create; 

finalization 

  ImgData.Free; 

{$ENDIF} 

end.

Fortsetzung....

zusammenfalten · markieren

Delphi-Quellcode:

			// Program to pull the IPTC (Photoshop) information out of various 

// types of digital camera files.  This information can coexist in 

// files containing EXIF data.  See README.TXT and LICENSE.TXT for 

// information regarding the lawful use of this code. 

// 

// Initial Delphi unit - Gerry McGuire September 2001 - V 0.9 beta 

//-------------------------------------------------------------------------- 

// This is based on an example provided by Earl F. Glynn. 

// His web pages on graphics and Delphi programming at http://www.efg2.com 

// have no equal! 

//-------------------------------------------------------------------------- 

// I have found several often conflicting IPTC definitions in use. 

// This code is designed to be easily extended.  For each new field 

// enter one line in the IPTCTable and increment the TagCnt constant. 

//-------------------------------------------------------------------------- 

unit dIPTC; 

interface 

  uses classes, windows, sysutils 

{$IFNDEF dExifNoJpeg} 

  ,jpeg 

{$ENDIF}; 

const dIPTCVersion = '1.02a'; 

      TagArrayGrowth = 25; 

type 

  StrFunct = function (instr:string): string; 

  TTagEntry = record 

    TID: integer;        // TagTableID - EXIF use 

    TType: word;         // tag type 

    ICode: Word;         // iptc code 

    Tag: word;           // primary key 

    Name: string;        // searchable 

    Desc: string;        // translatable 

    Code: string;        // decode capability 

    Data: string;        // display value 

    Raw: string;         // unprocessed value 

    PRaw: integer;       // pointer to unprocessed 

    FormatS:string;      // Format string 

    Size: integer;       // used by ITPC module 

    CallBack: StrFunct;  // formatting string 

  end; 

  TTagDefArray = array of TTagEntry; 

  { 

  ITag = record 

    ICode: word; 

    Tag:  word; 

    Name: string; 

    Desc: string; 

    Size: word; 

    Data: string; 

  end; 

    } 

  ITag = TTagEntry; 

  TIPTCdata = class 

  private 

    function getTimeZoneStr: string; 

  protected 

    MaxTag: integer; 

    parent: tobject; 

    fITagCount : integer; 

    fITagArray: array of iTag; 

    function GetTagElement(TagID: integer): ITag; 

    procedure SetTagElement(TagID: integer; const Value: ITag); 

    function GetCount: integer; 

    procedure SetCount(const Value: integer); 

    procedure SetDateTimePrim(TimeIn: TDateTime; prefix:string); 

  public 

//    Filename : string; 

    constructor Create(p:tobject); 

    procedure Reset; 

    property ITagArray[TagID:integer]: ITag 

        read GetTagElement write SetTagElement; default; 

    property Count : integer read GetCount write SetCount; 

    function HasData: boolean; 

    Function Clone(source:TIPTCdata):TIPTCdata; 

    Function ParseIPTCStrings(buff:string):tstringlist; 

    Procedure ParseIPTCArray; overload; 

    Procedure ParseIPTCArray(buff:string);  overload; 

    function IPTCArrayToBuffer:string; 

    function IPTCArrayToXML:tstringlist; 

    function LookupTag(SearchStr:string):integer; virtual; 

    Function LookupTagDefn(item: string): integer; 

    function LookupTagByDesc(SearchStr: string): integer; 

    procedure RemoveTag( tagstr: string ); virtual; 

    function AddTag(tagstr: string; dataval:string = ''):integer; virtual; 

    function AppendToTag(tagstr: string; dataval:string):integer; virtual; 

    function AddOrAppend(tagstr: string; dataval:string):integer; virtual; 

    function UpdateTag(tagstr, dataval: string): integer; 

    procedure SetTagByIdx(idx:integer; val:string); 

    function GetTag(tagstr: string; defval: string=''):string; virtual; 

    function ReadFile(fname:string):boolean; virtual; 

    function ReadFileStrings(fname: string):tstringlist; 

    function AddTagToArray(nextTag: iTag): integer; 

    function GetDateTime: TDateTime; 

    procedure SetDateTime(TimeIn: TDateTime); 

    procedure SetDateTimeExt(TimeIn: TDateTime; prefix:string); 

    function GetMultiPartTag(tagName:string):tstringlist; 

    procedure WriteFile(fname:string;origname:string = ''); overload; 

{$IFNDEF dExifNoJpeg} 

    procedure WriteFile(fname:string;memImage:tjpegimage); overload; 

{$ENDIF} 

  end; 

const IPTCTAGCNT = 49; 

      MultiTagSep = ','; 

var 

  rawDefered : boolean = false; 

  defaultTimeZone: string = '_0000'; 

  IPTCMultiTags: set of byte = [20,25]; 

  IPTCTable : array [0..IPTCTAGCNT-1] of ITag = 

    (( ICode: 2; Tag:  0; Name:'SKIP';         Desc:'Record Version';  Size:64), 

     ( ICode: 2; Tag:  3; Name:'ObjectType';   Desc:'Object Type Ref';  Size:67), 

     ( ICode: 2; Tag:  4; Name:'ObjectAttr';   Desc:'Object Attribute Ref';  Size:67), 

     ( ICode: 2; Tag:  5; Name:'ObjectName';   Desc:'Object name';  Size:64), 

     ( ICode: 2; Tag:  7; Name:'EditStatus';   Desc:'Edit Status';  Size:64), 

     ( ICode: 2; Tag:  8; Name:'EditorialUpdate';  Desc:'Editorial Update';  Size:2), 

     ( ICode: 2; Tag: 10; Name:'Urgency';      Desc:'Urgency';      Size:1), 

     ( ICode: 2; Tag: 12; Name:'SubRef';       Desc:'Subject Reference';     Size:236), 

     ( ICode: 2; Tag: 15; Name:'Category';     Desc:'Category';     Size:3), 

     ( ICode: 2; Tag: 20; Name:'SuppCategory'; Desc:'Supplemental category'; Size:32), 

     ( ICode: 2; Tag: 22; Name:'FixtureID';    Desc:'Fixture ID';   Size:32), 

     ( ICode: 2; Tag: 25; Name:'Keywords';     Desc:'Keywords';     Size:64), 

     ( ICode: 2; Tag: 26; Name:'ContentLocCode'; Desc:'Content Location Code'; Size: 3), 

     ( ICode: 2; Tag: 27; Name:'ContentLocName'; Desc:'Content Location Name'; Size: 64), 

     ( ICode: 2; Tag: 30; Name:'ReleaseDate';  Desc:'Release Date'; Size:8), 

     ( ICode: 2; Tag: 35; Name:'ReleaseTime';  Desc:'Release Time'; Size:11), 

     ( ICode: 2; Tag: 37; Name:'ExpireDate';  Desc:'Expiration Date'; Size:8), 

     ( ICode: 2; Tag: 38; Name:'ExpireTime';  Desc:'Expiration Time'; Size:11), 

     ( ICode: 2; Tag: 40; Name:'SpecialInstru'; Desc:'Special Instructions'; Size:256), 

     ( ICode: 2; Tag: 42; Name:'ActionAdvised'; Desc:'Action Advised'; Size:2), 

     ( ICode: 2; Tag: 45; Name:'RefService';    Desc:'Reference Service'; Size:10), 

     ( ICode: 2; Tag: 47; Name:'RefDate';  Desc:'Reference Date'; Size:8), 

     ( ICode: 2; Tag: 50; Name:'RefNumber';    Desc:'Reference Number'; Size:8), 

     ( ICode: 2; Tag: 55; Name:'DateCreated';  Desc:'Date created'; Size:8), 

     ( ICode: 2; Tag: 60; Name:'TimeCreated';  Desc:'Time created'; Size:11), 

     ( ICode: 2; Tag: 62; Name:'DigitizeDate';  Desc:'Digital Creation Date'; Size:8), 

     ( ICode: 2; Tag: 63; Name:'DigitizeTime';  Desc:'Digital Creation Time'; Size:11), 

     ( ICode: 2; Tag: 65; Name:'OriginatingProgram'; Desc:'Originating Program'; Size: 32), 

     ( ICode: 2; Tag: 70; Name:'ProgramVersion'; Desc:'Program version'; Size: 10), 

     ( ICode: 2; Tag: 75; Name:'ObjectCycle';  Desc:'Object Cycle'; Size:1), 

     ( ICode: 2; Tag: 80; Name:'ByLine';       Desc:'ByLine';       Size:32), 

     ( ICode: 2; Tag: 85; Name:'ByLineTitle';  Desc:'ByLine Title'; Size:32), 

     ( ICode: 2; Tag: 90; Name:'City';         Desc:'City';         Size:32), 

     ( ICode: 2; Tag: 92; Name:'SubLocation';  Desc:'Sublocation';  Size:32), 

     ( ICode: 2; Tag: 95; Name:'State';        Desc:'Province/State';  Size:32), 

     ( ICode: 2; Tag:100; Name:'LocationCode'; Desc:'Country/Primary Location Code'; Size: 3), 

     ( ICode: 2; Tag:101; Name:'LocationName'; Desc:'Country/Primary Location Name'; Size:   64), 

     ( ICode: 2; Tag:103; Name:'TransmissionRef'; Desc:'Original Transmission Reference';     Size:   32), 

     ( ICode: 2; Tag:105; Name:'ImageHeadline'; Desc:'Image headline'; Size:256), 

     ( ICode: 2; Tag:110; Name:'ImageCredit';  Desc:'Image credit';  Size:32), 

     ( ICode: 2; Tag:115; Name:'Source';       Desc:'Source';        Size:32), 

     ( ICode: 2; Tag:116; Name:'Copyright';    Desc:'Copyright Notice';  Size:128), 

     ( ICode: 2; Tag:118; Name:'Contact';      Desc:'Contact';       Size:128), 

     ( ICode: 2; Tag:120; Name:'ImageCaption'; Desc:'Image caption'; Size:2000), 

     ( ICode: 2; Tag:122; Name:'ImageCaptionWriter'; Desc:'Image caption writer'; Size:32), 

     ( ICode: 2; Tag:130; Name:'ImageType';    Desc:'Image type';    Size:2 ), 

     ( ICode: 2; Tag:131; Name:'Orientation';  Desc:'Image Orientation'; Size:1 ), 

     ( ICode: 2; Tag:135; Name:'LangID';       Desc:'Language ID';   Size:3 ), 

     ( ICode: 8; Tag:10;  Name:'Subfile';      Desc:'Subfile';       Size:2 ) 

    ); 

procedure IPTCWriteTransFile(fname:string); 

function IPTCReadTransFile(fname:string):boolean; 

implementation 

uses dEXIF; 

var 

  buffer:string; 

constructor TIPTCdata.Create(p:tobject); 

begin 

  inherited create; 

  fITagCount := 0; 

  parent := p; 

end; 

function TIPTCdata.GetCount: integer; 

begin 

  result := fITagCount; 

end; 

procedure TIPTCdata.SetCount(const Value: integer); 

begin 

  fITagCount := value; 

end; 

function TIPTCdata.GetTagElement(TagID: integer): ITag; 

begin 

  result := fITagArray[TagID] 

end; 

procedure TIPTCdata.SetTagElement(TagID: integer; const Value: ITag); 

begin 

  fITagArray[TagID] := Value; 

end; 

Function ExtractTag(var start:integer):iTag; 

var blen,x,tagId,code,i:integer; 

    tmp:iTag; 

begin 

  FillChar(tmp,sizeof(iTag),0); 

  code := byte(buffer[start]); 

  tagId := byte(buffer[start+1]);     // should be #$1C 

  blen := (byte(buffer[start+2]) shl 8 ) or byte(buffer[start+3]); 

  x := blen; 

  inc(start,4);                      // skip length bytes 

  if code in [2,8] then 

  begin 

    tmp.Tag := 65534; 

    for i := 0 to IPTCTAGCNT-1 do 

      if (IPTCTable[i].Tag = tagid) and 

         (IPTCTable[i].ICode = code) then 

      begin 

        if IPTCTable[i].name <> 'SKIP' then 

        begin 

          tmp := IPTCTable[i]; 

          tmp.Data := copy(buffer,start,x); 

        end; 

        break; 

      end; 

    if tmp.Tag = 65534 then 

    begin 

      tmp.name := 'Custom_'+inttostr(tagid); 

      tmp.Desc := 'Custom_'+inttostr(tagid); 

      tmp.Tag := tagid; 

      tmp.ICode := code; 

      tmp.Data := copy(buffer,start,x); 

      tmp.Size := 64; // length for unknown fields ? 

    end; 

  end; 

  start := start+x+1; 

  result := tmp; 

end; 

//  This function returns the index of a tag name 

//  in the tag buffer. 

Function TIPTCdata.LookupTag(SearchStr:string):integer; 

var i: integer; 

begin 

 SearchStr := UpperCase(SearchStr); 

 result := -1; 

 for i := 0 to Count-1 do 

   if UpperCase(iTagArray[i].Name) = SearchStr then 

   begin 

     result := i; 

     break; 

   end; 

end; 

//  This function returns the index of a tag name 

//  in the tag buffer. It searches by the description 

//  which is most likely to be used as a label 

Function TIPTCdata.LookupTagByDesc(SearchStr:string):integer; 

var i: integer; 

begin 

 SearchStr := UpperCase(SearchStr); 

 result := -1; 

 for i := 0 to Count-1 do 

   if UpperCase(iTagArray[i].Desc) = SearchStr then 

   begin 

     result := i; 

     break; 

   end; 

end; 

//  This function returns the index of a tag definition 

//  for a given tag name. 

function TIPTCdata.LookupTagDefn(item: string): integer; 

var i:integer; 

begin 

  result := -1; 

  for i := 0 to IPTCTAGCNT-1 do 

  begin 

    if lowercase(item) = lowercase(IPTCtable[i].Name) then 

    begin 

      result := i; 

      break; 

    end; 

  end; 

end; 

Function TIPTCdata.ParseIPTCStrings(buff:string):tstringlist; 

var ts:tstringlist; 

    tmpItem:itag; 

    start,i,j:Integer; 

begin 

  ts := tstringlist.Create; 

  buffer := buff; 

  i := pos('Photoshop 3.0',buff)+13; 

  for j := i to length(buffer) do       // Look for first field marker 

    if ( byte(buffer[j]) = $1C) and 

       ( byte(buffer[j+1]) in [2,8]) then 

      break; 

  start := j+1; 

  while (start < length(buffer)-2) do   // Work through buffer 

  begin 

    tmpItem := ExtractTag(start); 

    if tmpItem.Name <> '' then         // Empty fields are masked out 

      ts.Add(tmpItem.Desc+DexifDelim+tmpItem.Data); 

  end; 

  result := ts; 

end; 

function TIPTCdata.AddTagToArray(nextTag:iTag):integer; 

begin 

  if nextTag.tag <> 0 then     // Empty fields are masked out 

  begin 

    if fITagCount >= MaxTag-1 then 

    begin 

      inc(MaxTag,TagArrayGrowth); 

      SetLength(fITagArray,MaxTag); 

    end; 

    fITagArray[fITagCount] := nextTag; 

    inc(fITagCount); 

  end; 

  result := fITagCount-1; 

end; 

Procedure TIPTCdata.ParseIPTCArray; 

begin 

  ParseIPTCArray(timgdata(parent).IPTCsegment^.data); 

end; 

Procedure TIPTCdata.ParseIPTCArray(buff:string); 

var nextTag:itag; 

    start,i,j:Integer; 

begin 

  reset; 

  buffer := buff; 

  i := pos('Photoshop 3.0',buff)+13; 

  for j := i to length(buffer) do       // Look for first field marker 

    if ( byte(buffer[j]) = $1C) and 

       ( byte(buffer[j+1]) in [2,8]) then 

      break; 

  start := j+1; 

  while (start < length(buffer)-2) do   // Work through buffer 

  begin 

    nextTag := ExtractTag(start);       // Start is incremented by function 

    if nextTag.Tag in IPTCMultiTags then 

    begin 

      AppendToTag(nextTag.Name,nextTag.Data) 

    end 

    else 

      AddTagToArray(nextTag); 

  end; 

end; 

function MakeEntry(code,tag:integer;data:string):string; 

var buff,sLen:string; 

  bLen:integer; 

begin 

  bLen := length(Data); 

  sLen := char(blen div 256)+char(blen mod 256); 

  result := buff+char($1C)+char(code)+char(tag)+sLen+Data; 

end; 

function TIPTCdata.IPTCArrayToXML: tstringlist; 

var buff:tstringlist; 

  i:integer; 

begin 

  buff := TStringList.Create; 

  buff.add('   <ITPCdata>'); 

  for i := 0 to Count-1 do 

    with ITagArray[i] do 

    begin 

      buff.add('   <'+name+'>'); 

      if tag in [105,120] // headline and image caption 

        then buff.add('      <![CDATA['+data+']]>') 

        else buff.add('      '+data); 

      buff.add('   </'+name+'>'); 

    end; 

  buff.add('   </ITPCdata>'); 

  result := buff; 

end; 

function SplitMultiTag(code, tag:integer; buff:string):string; 

var tmps:string; 

  j:integer; begin 

  result := ''; 

  while trim(buff) <> '' do 

  begin 

    j := pos(MultiTagSep,buff); 

    if j > 0 then 

    begin 

      tmps := trim(copy(buff,1,j-1)); 

      buff := trim(copy(buff,j+1,maxint)); 

    end 

    else 

    begin 

      tmps := buff; 

      buff := ''; 

    end; 

    result := result+MakeEntry(code,tag,tmps); 

  end; 

end; 

function TIPTCdata.IPTCArrayToBuffer:string; 

var buff,slen,h2:string; 

  blen,i:integer; 

begin 

  buff := ''; 

  // load up the particular data 

  for i := 0 to Count-1 do 

    with ITagArray[i] do 

    if (icode=2) and (tag in IPTCMultiTags) then 

      buff := buff+SplitMultiTag(icode,tag,data) 

    else 

      buff := buff+MakeEntry(icode,tag,data); 

// Photoshop requires the following headers: 

  if not odd(length(buff)) then 

    buff := buff+#0; 

  h2 := MakeEntry(2,0,#0#2); 

  bLen := length(buff)+length(h2); 

  sLen := char(blen div 256)+char(blen mod 256); 

  buff := 'Photoshop 3.0'#0'8BIM'#4#4#0#0#0#0+slen+h2+buff; 

// Photoshop requires the following End-of-data marker: 

  result := buff+'8BIM'#$04#$0B#0#0#0#0#0#0; 

end; 

function TIPTCdata.Clone(source: TIPTCdata): TIPTCdata; 

var newie:TIPTCdata; 

begin 

  newie := TIPTCdata.Create(parent); 

  newie.fITagArray := copy(source.fITagArray,0,MaxTag); 

  newie.fITagCount := source.fITagCount; 

  result := newie; 

end; 

function TIPTCdata.AddOrAppend(tagstr, dataval: string): integer; 

var nextTag:iTag; 

  i:integer; 

begin 

  result := -1; 

  i := LookupTagDefn(tagStr); 

  if i >= 0 then 

  begin 

    nextTag := ITagArray[i]; 

    if (nextTag.icode = 2) and (nextTag.Tag in IPTCMultiTags) 

      then result := AddTag(tagstr,dataval) 

      else result := AppendToTag(tagstr,dataVal); 

  end; 

end; 

function TIPTCdata.AppendToTag(tagstr, dataval: string): integer; 

var inspt:integer;   // INSertion PoinT 

begin 

  inspt := LookupTag(tagstr); 

  if (inspt >= 0) then 

  begin 

    if dataval <> '' then 

      fITagArray[inspt].Data := 

          fITagArray[inspt].Data+MultiTagSep+dataval 

  end 

  else 

    inspt := AddTag(tagstr,dataval); 

  result := inspt; 

end; 

function TIPTCdata.UpdateTag(tagstr, dataval: string): integer; 

var inspt:integer;   // INSertion PoinT 

begin 

  inspt := LookupTag(tagstr); 

  if (inspt >= 0) then 

  begin 

    if dataval <> '' then 

      fITagArray[inspt].Desc := dataval 

  end; 

  result := inspt; 

end; 

function TIptcData.GetMultiPartTag(tagName:string):tstringlist; 

var tmp:tstringlist; 

begin 

  tmp := tstringlist.create; 

  tmp.CommaText := StringReplace( 

    GetTag(tagname),MultiTagSep,',',[rfReplaceAll]); 

  result := tmp; 

end; 

function TIPTCdata.AddTag(tagstr, dataval: string): integer; 

var inspt,defidx:integer; 

  newTag:itag; 

begin 

  inspt := LookupTag(tagstr); 

  if (inspt >= 0) then 

  begin 

    if dataval <> '' then 

      fITagArray[inspt].Data := dataval 

 end 

  else 

  begin 

    defidx := LookupTagDefn(tagstr); 

    if defidx < 0 then 

    begin 

      result := -1; 

      exit;  // not a defined node, do not insert 

    end; 

    newTag := IPTCTable[defidx]; 

    newTag.Data := dataVal; 

    inspt := AddTagToArray(newTag); 

  end; 

  result := inspt; 

end; 

procedure TIPTCdata.RemoveTag(tagstr: string); 

var rempt,i:integer; 

begin 

 rempt := LookupTag(tagstr); 

 if (rempt >= 0) then 

 begin 

   for i := rempt to fITagCount-2 do 

     fITagArray[i] := fITagArray[i+1]; 

   dec(fITagCount); 

 end; 

end; 

procedure TIPTCdata.Reset; 

begin 

 Count := 0 ; 

 FillChar(fITagArray[0],sizeof(iTag)*MaxTag,0);  // clear out old data 

end; 

function TIPTCdata.GetTag(tagstr: string; defval: string=''): string; 

var i:integer; 

begin 

  result := defval; 

  i := LookupTag(tagstr); 

  if i >=0 then 

    result := ITagArray[i].Data; 

end; 

Function TIPTCdata.HasData:boolean; 

begin 

  result := Count > 0; 

end; 

function TIPTCdata.ReadFile(fname: string):boolean; 

var p:tImgData; 

begin 

  p := tImgData(parent); 

  Reset; 

  p.ProcessFile(FName);                      // Get data from file. 

  if p.IPTCSegment <> nil then               // If IPTC segment detected 

  begin 

    ParseIPTCArray(p.IPTCSegment^.Data); 

//    filename := FName; 

  end; 

  result := HasData(); 

end; 

function TIPTCdata.ReadFileStrings(fname: string):tstringlist; 

begin 

  result := ParseIPTCStrings(timgdata(parent).IPTCSegment^.Data); 

end; 

{$IFNDEF dExifNoJpeg} 

procedure TIPTCdata.WriteFile(fname:string;memImage:tjpegimage); 

var tmp:string; 

begin 

  tmp := IPTCArrayToBuffer;                       // Create temp buffer 

  timgdata(parent).MakeIPTCSegment(tmp);          // Create IPTC segment 

  timgdata(parent).WriteEXIFjpeg(memImage,FName); // Write to disk 

end; 

procedure TIPTCdata.WriteFile(FName: string; OrigName : string = ''); 

var tmp:string; 

    Orig:tjpegimage; 

begin 

  Orig := TJPEGImage.Create; 

  if OrigName = '' then 

    OrigName := FName; 

  Orig.LoadFromFile(OrigName);                // Get the image 

  tmp := IPTCArrayToBuffer;                   // Create temp buffer 

  timgdata(parent).MakeIPTCSegment(tmp);      // Create IPTC segment 

  timgdata(parent).WriteEXIFjpeg(Orig,FName); // Write to disk 

  Orig.free; 

end; 

{$ELSE} 

procedure TIPTCdata.WriteFile(fname: string; origname : string = ''); 

begin 

  // if you're not using Borland's jpeg unit 

  // then you should override/avoid this method 

  raise exception.create('WriteIPTCfile does nothing!'); 

  // I suppose I should make this method abstract... 

end; 

{$ENDIF} 

procedure TIPTCdata.SetTagByIdx(idx: integer; val: string); 

begin 

  fITagArray[idx].Data := val; 

end; 

function GetTimeZoneBias:longint; 

var 

  TZoneInfo: TTimeZoneInformation; 

  //TimeZoneBias: longint; 

begin 

  GetTimeZoneInformation(TZoneInfo); 

  result := TZoneInfo.Bias; 

end; 

function TIPTCdata.getTimeZoneStr:string; 

var tmp,h,m:integer; 

    sign:string; 

begin 

  result := defaultTimeZone; 

  if defaultTimeZone <> '_0000' then 

    exit; 

  tmp := GetTimeZoneBias(); 

  h := abs(tmp) div 60; // hours 

  m := abs(tmp) mod 60; // minutes 

  if tmp < 0         // local time correction: invertsign 

    then sign := '+' 

    else sign := '-'; 

  result := Format('%s%.2d%.2d',[sign,h,m]); 

end; 

procedure TIPTCdata.SetDateTimePrim(TimeIn:TDateTime; prefix:string); 

var dateStr, timeStr, timeZone:string; 

begin 

  if lowercase(prefix) = 'default' then 

  begin 

    datestr := 'DateCreated'; 

    timestr := 'TimeCreated'; 

  end 

  else 

  begin 

    datestr := prefix+'Date'; 

    timestr := prefix+'Time'; 

  end; 

  timeZone := getTimeZoneStr();  // use local time zone 

  AddTag(datestr,FormatDateTime('yyyymmdd',TimeIn)); 

  AddTag(timestr,FormatDateTime('hhnnss',TimeIn)+timeZone); 

end; 

procedure TIPTCdata.SetDateTime(TimeIn:TDateTime); 

begin 

  SetDateTimePrim(TimeIn,'Default'); 

end; 

procedure TIPTCdata.SetDateTimeExt(TimeIn:TDateTime; prefix:string); 

begin 

  SetDateTimePrim(TimeIn,prefix); 

end; 

function TIPTCdata.GetDateTime:TDateTime; 

type 

  TConvert= packed record 

     year: Array [1..4] of char; 

     mon, day, hr, min, sec: Array [1..2] of Char; 

  end; 

  PConvert= ^TConvert; 

var 

   tsd,tst:string; 

begin 

   try 

     tsd := GetTag('DateCreated','00000000'); 

     tst := tsd+GetTag('TimeCreated','000000'); 

     with PConvert( @tst[1] )^ do 

       Result := EncodeDate( StrToInt( year ), 

                             StrToInt( mon ), 

                             StrToInt( day )) 

              +  EncodeTime( StrToInt( hr  ), 

                             StrToInt( min ), 

                             StrToInt( sec ), 0); 

   except 

     result := 0; 

   end; 

end; 

procedure IPTCWriteTransFile(fname:string); 

var tmp:tstringlist; 

    i: integer; 

begin 

  tmp := tstringlist.Create; 

  for i := 0 to IPTCTAGCNT-1 do 

    tmp.Add( IPTCTable[i].Name+'='+ IPTCTable[i].Desc); 

  tmp.SaveToFile(fname); 

  tmp.Free; 

end; 

function IPTCReadTransFile(fname:string):boolean; 

var tmp:tstringlist; 

    i: integer; 

    ts:string; 

begin 

  result := false; 

  if not fileexists(fname) then 

    exit; 

  tmp := tstringlist.Create; 

  tmp.LoadFromFile(fname); 

  for i := 0 to IPTCTAGCNT-1 do 

  begin 

    ts := tmp.Values[IPTCTable[i].Name]; 

    if ts > '' then 

      IPTCTable[i].Desc := ts; 

  end; 

  tmp.Free; 

end; 

end.

Von Michael Puff:

http://www.michael-puff.de/Programmi...ExifReader.zip

dEXIF - Copyright 2001-2004, Gerry McGuire:

http://www.delphipraxis.net/attachme...fv103d_147.zip

CCR Exif is a Delphi library to read and write Exif, IPTC and XMP metadata from JPEG, TIFF and PSD images:

https://code.google.com/p/ccr-exif/

https://ccr-exif.googlecode.com/file...f%20v1.5.1.zip

JPG-Header lesen und speichern

AW: Re: JPG-Header lesen und speichern

AW: JPG-Header lesen und speichern

AW: JPG-Header lesen und speichern

AW: JPG-Header lesen und speichern

AW: JPG-Header lesen und speichern

Forumregeln

tcoman (Gast) n/a Beiträge	#12 AW: JPG-Header lesen und speichern 30. Jul 2015, 18:03 Zitat von himitsu: eventuell handelt es sich hierbei um die gewünschte Datei dEXIF.pas > http://my-svn.assembla.com/svn/App_Smallsee/dEXIF.pas Leider funktioniert auch dieser Link nicht mehr !
	Zitat