JPG-Header lesen und speichern

[hathor]

Fortsetzung....

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.