|
hathor
(Gast)
n/a Beiträge |
#12
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. |
![]() |
Ansicht |
![]() |
![]() |
![]() |
ForumregelnEs 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
|
|
Nützliche Links |
Heutige Beiträge |
Sitemap |
Suchen |
Code-Library |
Wer ist online |
Alle Foren als gelesen markieren |
Gehe zu... |
LinkBack |
![]() |
![]() |