AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Zurück Delphi-PRAXiS Programmierung allgemein Multimedia Delphi JPG-Header lesen und speichern
Thema durchsuchen
Ansicht
Themen-Optionen

JPG-Header lesen und speichern

Ein Thema von ThoPos · begonnen am 29. Apr 2008 · letzter Beitrag vom 30. Jul 2015
 
hathor
(Gast)

n/a Beiträge
 
#12

AW: JPG-Header lesen und speichern

  Alt 30. Jul 2015, 18:31
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 <> 'SKIPthen
        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 <> '_0000then
    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) = 'defaultthen
  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.
  Mit Zitat antworten Zitat
 


Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 20:32 Uhr.
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024-2025 by Thomas Breitkreuz