824c594816
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6090 8e941d3f-bd1b-0410-a28a-d453659cc2b4
682 lines
20 KiB
ObjectPascal
682 lines
20 KiB
ObjectPascal
unit fpeIptcData;
|
|
|
|
{$IFDEF FPC}
|
|
{$MODE Delphi}
|
|
{$ENDIF}
|
|
|
|
{$I fpexif.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, Contnrs,
|
|
fpeGlobal, fpeTags;
|
|
|
|
type
|
|
TIptcData = class
|
|
private
|
|
FTagList: TTagList;
|
|
FImageResourceBlocks: TObjectList;
|
|
function GetTagByID(ATagID: TTagID): TTag;
|
|
function GetTagByIndex(AIndex: Integer): TTag;
|
|
function GetTagByName(ATagName: String): TTag;
|
|
function GetTagCount: Integer;
|
|
procedure SetTagByID(ATagID: TTagID; const ATag: TTag);
|
|
procedure SetTagByIndex(AIndex: Integer; const ATag: TTag);
|
|
procedure SetTagByName(ATagName: String; const ATag: TTag);
|
|
protected
|
|
function IndexOfTagID(ATagID: TTagID): Integer;
|
|
function IndexOfTagName(ATagName: String): Integer;
|
|
function InternalAddTag(ATagDef: TTagDef): TTag;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure AddImageResourceBlock(AIdentifier: Word; AName: String; AData: TBytes);
|
|
function AddTag(ATag: TTag): Integer;
|
|
function AddTagByName(ATagName: String): TTag;
|
|
procedure AppendTagTo(ATag, AParentTag: TTag);
|
|
procedure Clear;
|
|
procedure ExportToStrings(AList: TStrings; AOptions: TExportOptions;
|
|
ASeparator: String = '=');
|
|
procedure GetImageResourceBlock(AIndex: Integer; out AIdentifier: Word;
|
|
out AName: String; out AData: TBytes);
|
|
function GetImageResourceBlockCount: Integer;
|
|
property TagbyID[ATagID: TTagID]: TTag
|
|
read GetTagByID write SetTagByID;
|
|
property TagByIndex[AIndex: Integer]: TTag
|
|
read GetTagByIndex write SetTagByIndex;
|
|
property TagByName[ATagName: String]: TTag
|
|
read GetTagByName write SetTagByName;
|
|
property TagCount: Integer
|
|
read GetTagCount;
|
|
end;
|
|
|
|
type
|
|
TIptcStringTag = class(TStringTag)
|
|
private
|
|
FMaxLen: Integer;
|
|
public
|
|
constructor Create(ATagDef: TTagDef; AOptions: TTagOptions); override;
|
|
property MaxLength: Integer read FMaxLen;
|
|
end;
|
|
|
|
TIptcMultiStringTag = class(TIptcStringTag)
|
|
protected
|
|
function GetAsString: String; override;
|
|
procedure SetAsString(const AValue: String); override;
|
|
public
|
|
procedure AddString(const AValue: String); virtual;
|
|
end;
|
|
|
|
TIptcObjectAttrTag = class(TIptcMultiStringTag)
|
|
public
|
|
procedure AddString(const AValue: String); override;
|
|
end;
|
|
|
|
TIptcUrgencyTag = class(TIptcStringTag)
|
|
protected
|
|
procedure SetAsString(const AValue: String); override;
|
|
end;
|
|
|
|
TIptcDateTag = class(TIptcStringTag)
|
|
private
|
|
function GetFormat: String;
|
|
protected
|
|
function GetAsDate: TDateTime;
|
|
function GetAsString: String; override;
|
|
procedure SetAsDate(const AValue: TDateTime);
|
|
procedure SetAsString(const AValue: String); override;
|
|
public
|
|
property AsDate: TDateTime read GetAsDate write SetAsDate;
|
|
property FormatStr; // e.g. 'yyyy-mm-dd';
|
|
end;
|
|
|
|
TIptcTimeTag = class(TIptcStringTag)
|
|
private
|
|
function GetFormat: String;
|
|
protected
|
|
function GetAsString: String; override;
|
|
function GetAsTime: TDateTime;
|
|
procedure SetAsString(const AValue: String); override;
|
|
procedure SetAsTime(const AValue: TDateTime);
|
|
public
|
|
property AsTime: TDateTime read GetAsTime write SetAsTime;
|
|
property FormatStr; // e.g. 'hh:nn';
|
|
end;
|
|
|
|
procedure BuildIptcTagDefs;
|
|
procedure FreeIptcTagDefs;
|
|
function FindIptcTagDef(ATagID: TTagID): TTagDef; overload;
|
|
function FindIptcTagDef(ATagName: String): TTagDef; overload;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
Math, DateUtils, StrUtils, Variants,
|
|
fpeStrConsts, fpeUtils;
|
|
|
|
type
|
|
TAdobeImageResourceBlock = class
|
|
Identifier: Word;
|
|
Name: String;
|
|
Data: TBytes;
|
|
end;
|
|
|
|
var
|
|
IptcTagDefs: TTagDefList = nil;
|
|
|
|
procedure BuildIptcTagDefs;
|
|
const
|
|
I = DWord(TAGPARENT_IPTC); // for shorter lines...
|
|
begin
|
|
if IptcTagDefs = nil then
|
|
IptcTagDefs := TTagDefList.Create;
|
|
with IptcTagDefs do begin
|
|
Clear;
|
|
// NOTE: The Count field is "abused" as MaxLength of string value
|
|
AddStringTag(I+$015A {1:90}, 'CodedCharacterSet', 32, rsCodedCharSet, '', TIptcStringTag);
|
|
AddUShortTag(I+$0200 {2: 0}, 'RecordVersion', 1, rsRecordVersion);
|
|
AddStringTag(I+$0203 {2: 3}, 'ObjectType', 64, rsObjectType, '', TIptcStringTag);
|
|
AddStringTag(I+$0204 {2: 4}, 'ObjectAttr', 68, rsObjectAttr, '', TIptcObjectAttrTag);
|
|
AddStringTag(I+$0205 {2: 5}, 'ObjectName', 64, rsObjectName, '', TIptcStringTag);
|
|
AddStringTag(I+$0207 {2: 7}, 'EditStatus', 64, rsEditStatus, '', TIptcStringTag);
|
|
AddStringTag(I+$0208 {2: 8}, 'EditorialUpdate', 2, rsEditorialUpdate,'', TIptcStringTag);
|
|
AddStringTag(I+$020A {2:10}, 'Urgency', 1, rsUrgency, rsUrgencyLkUp, TIptcUrgencyTag);
|
|
AddStringTag(I+$020C {2:12}, 'SubRef', 236, rsSubjectRef, '', TIptcMultiStringTag); // Min 13
|
|
AddStringTag(I+$020F {2:15}, 'Category', 3, rsCategory, '', TIptcStringTag);
|
|
AddStringTag(I+$0214 {2:20}, 'SuppCategory', 32, rsSuppCategory, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$0216 {2:22}, 'FixtureID', 32, rsFixtureID, '', TIptcStringTag);
|
|
AddStringTag(I+$0219 {2:25}, 'KeyWords', 64, rsKeyWords, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$021A {2:26}, 'ContentLocCode', 3, rsContentLocCode, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$021B {2:27}, 'ContentLocName', 64, rsContentLocName, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$021E {2:30}, 'ReleaseDate', 8, rsReleaseDate, '', TIptcDateTag);
|
|
AddStringTag(I+$0223 {2:35}, 'ReleaseTime', 11, rsReleaseTime, '', TIptcTimeTag);
|
|
AddStringTag(I+$0225 {2:37}, 'ExpireDate', 8, rsExpireDate, '', TIptcStringTag);
|
|
AddStringTag(I+$0226 {2:38}, 'ExpireTime', 11, rsExpireTime, '', TIptcStringTag);
|
|
AddStringTag(I+$0228 {2:40}, 'SpecialInstruct', 256, rsSpecialInstruct,'', TIptcStringTag);
|
|
AddStringTag(I+$022A {2:42}, 'ActionAdvised', 2, rsActionAdvised, '', TIptcStringTag);
|
|
AddStringTag(I+$022D {2:45}, 'RefService', $FFFF, rsRefService, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$022F {2:47}, 'RefDate', $FFFF, rsRefDate, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$0232 {2:50}, 'RefNumber', $FFFF, rsRefNumber, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$0237 {2:55}, 'DateCreated', 8, rsDateCreated, '', TIptcDateTag);
|
|
AddStringTag(I+$023C {2:60}, 'TimeCreated', 11, rsTimeCreated, '', TIptcTimeTag);
|
|
AddStringTag(I+$023E {2:62}, 'DigitizeDate', 8, rsDigitizeDate, '', TIptcDateTag);
|
|
AddStringTag(I+$023F {2:63}, 'DigitizeTime', 11, rsDigitizeTime, '', TIptcTimeTag);
|
|
AddStringTag(I+$0241 {2:65}, 'OriginatingProgram',32, rsOriginatingProg,'', TIptcStringTag);
|
|
AddStringTag(I+$0246 {2:70}, 'ProgramVersion', 10, rsProgVersion, '', TIptcStringTag);
|
|
AddStringTag(I+$024B {2:75}, 'ObjectCycle', 1, rsObjectCycle, rsObjectCycleLkup, TIptcStringTag);
|
|
AddStringTag(I+$0250 {2:80}, 'ByLine', 32, rsByLine, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$0255 {2:85}, 'ByLineTitle', 32, rsByLineTitle, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$025A {2:90}, 'City', 32, rsCity, '', TIptcStringTag);
|
|
AddStringTag(I+$025C {2:92}, 'SubLocation', 32, rsSubLocation, '', TIptcStringTag);
|
|
AddStringTag(I+$025F {2:95}, 'State', 32, rsState, '', TIptcStringTag);
|
|
AddStringTag(I+$0264 {2:100}, 'LocationCode', 3, rsLocationCode, '', TIptcStringTag);
|
|
AddStringTag(I+$0265 {2:101}, 'LocationName', 64, rsLocationName, '', TIptcStringTag);
|
|
AddStringTag(I+$0267 {2:103}, 'TransmissionRef', 32, rsTransmissionRef,'', TIptcStringTag);
|
|
AddStringTag(I+$0269 {2:105}, 'ImageHeadline', 256, rsImgHeadline, '', TIptcStringTag);
|
|
AddStringTag(I+$026E {2:110}, 'ImageCredit', 32, rsImgCredit, '', TIptcStringTag);
|
|
AddStringTag(I+$0273 {2:115}, 'Source', 32, rsSource, '', TIptcStringTag);
|
|
AddStringTag(I+$0274 {2:116}, 'Copyright', 128, rsCopyright, '', TIptcStringTag);
|
|
AddStringTag(I+$0276 {2:118}, 'Contact', 128, rsContact, '', TIptcMultiStringTag);
|
|
AddStringTag(I+$0278 {2:120}, 'ImageCaption', 2000, rsImgCaption, '', TIptcStringTag);
|
|
AddStringTag(I+$027A {2:122}, 'ImageCaptionWriter',32, rsImgCaptionWriter,'', TIptcStringTag);
|
|
AddStringTag(I+$0282 {2:130}, 'ImageType', 2, rsImgType, '', TIptcStringTag);
|
|
AddStringTag(I+$0283 {2:131}, 'Orientation', 1, rsOrientation, rsIptcOrientationLkup, TIptcStringTag);
|
|
AddStringTag(I+$0287 {2:135}, 'LangID', 3, rsLangID, '', TIptcStringTag);
|
|
end;
|
|
end;
|
|
|
|
|
|
function FindIptcTagDef(ATagID: TTagID): TTagDef;
|
|
begin
|
|
if IptcTagDefs = nil then
|
|
BuildIptcTagDefs;
|
|
Result := IptcTagDefs.FindByID(ATagID);
|
|
end;
|
|
|
|
function FindIptcTagDef(ATagName: String): TTagDef;
|
|
begin
|
|
if IptcTagDefs = nil then
|
|
BuildIptcTagDefs;
|
|
Result := IptcTagDefs.FindByName(ATagName);
|
|
end;
|
|
|
|
procedure FreeIptcTagDefs;
|
|
begin
|
|
FreeAndNil(IptcTagDefs);
|
|
end;
|
|
|
|
|
|
//==============================================================================
|
|
// TIptcData
|
|
//==============================================================================
|
|
|
|
constructor TIptcData.Create;
|
|
begin
|
|
BuildIptcTagDefs;
|
|
inherited Create;
|
|
FTagList := TTagList.Create;
|
|
FImageResourceBlocks := TObjectList.Create;
|
|
end;
|
|
|
|
destructor TIptcData.Destroy;
|
|
begin
|
|
FImageResourceBlocks.Free;
|
|
FTagList.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TIptcData.AddImageResourceBlock(AIdentifier: Word; AName: String;
|
|
AData: TBytes);
|
|
var
|
|
block: TAdobeImageResourceBlock;
|
|
begin
|
|
block := TAdobeImageResourceBlock.Create;
|
|
block.Identifier := AIdentifier;
|
|
block.Name := AName;
|
|
SetLength(block.Data, Length(AData));
|
|
if Length(AData) > 0 then
|
|
Move(AData[0], block.Data[0], Length(AData));
|
|
FImageResourceBlocks.Add(block);
|
|
end;
|
|
|
|
function TIptcData.AddTag(ATag: TTag): Integer;
|
|
var
|
|
idx: Integer;
|
|
begin
|
|
idx := IndexOfTagID(ATag.TagID);
|
|
if idx <> -1 then begin
|
|
// Replace existing tag
|
|
FTagList.Delete(idx);
|
|
FTagList.Insert(idx, ATag);
|
|
end else
|
|
// Add the new tag
|
|
Result := FTagList.Add(ATag);
|
|
end;
|
|
|
|
function TIptcData.AddTagByName(ATagName: String): TTag;
|
|
var
|
|
idx: Integer;
|
|
tagdef: TTagDef;
|
|
begin
|
|
idx := IndexOfTagName(ATagName);
|
|
if idx > -1 then
|
|
Result := FTagList[idx]
|
|
else begin
|
|
tagDef := FindIptcTagDef(ATagName);
|
|
Result := InternalAddTag(tagDef);
|
|
end;
|
|
end;
|
|
|
|
{ Adds ATag to AParentTag }
|
|
procedure TIptcData.AppendTagTo(ATag, AParentTag: TTag);
|
|
begin
|
|
Assert(ATag <> nil);
|
|
Assert(AParentTag <> nil);
|
|
Assert(ATag.TagID = AParentTag.TagID);
|
|
Assert(ATag.TagType = AParentTag.TagType);
|
|
|
|
if AParentTag is TIptcMultiStringTag then
|
|
TIptcMultiStringTag(AParentTag).AddString(ATag.AsString);
|
|
end;
|
|
|
|
procedure TIptcData.Clear;
|
|
begin
|
|
FImageResourceBlocks.Clear;
|
|
FTagList.Clear;
|
|
end;
|
|
|
|
procedure TIptcData.ExportToStrings(AList: TStrings; AOptions: TExportOptions;
|
|
ASeparator: String = '=');
|
|
var
|
|
i: Integer;
|
|
tag: TTag;
|
|
nam: String;
|
|
tagval: String;
|
|
usedExportOptions: TExportOptions;
|
|
begin
|
|
Assert(AList <> nil);
|
|
|
|
if TagCount = 0 then
|
|
exit;
|
|
|
|
if AList.Count > 0 then
|
|
AList.Add('');
|
|
AList.Add('*** IPTC ***');
|
|
|
|
for i := 0 to TagCount-1 do begin
|
|
tag := TagByIndex[i];
|
|
usedExportOptions := AOptions * [eoShowDecimalTagID, eoShowHexTagID];
|
|
if usedExportOptions = [eoShowDecimalTagID] then
|
|
nam := Format('[%d] %s', [tag.TagID, tag.Description])
|
|
else
|
|
if usedExportOptions = [eoShowHexTagID] then
|
|
nam := Format('[$%.4x] %s', [tag.TagID, tag.Description])
|
|
else
|
|
nam := tag.Description;
|
|
tagval := tag.AsString;
|
|
if tagval <> '' then
|
|
AList.Add(nam + ASeparator + tagval);
|
|
end;
|
|
end;
|
|
|
|
procedure TIptcData.GetImageResourceBlock(AIndex: Integer; out AIdentifier: Word;
|
|
out AName: String; out AData: TBytes);
|
|
var
|
|
block: TAdobeImageResourceBlock;
|
|
begin
|
|
block := TAdobeImageResourceBlock(FImageResourceBlocks[AIndex]);
|
|
AIdentifier := block.Identifier;
|
|
AName := block.Name;
|
|
SetLength(AData, Length(block.Data));
|
|
if Length(block.Data) > 0 then
|
|
Move(block.Data[0], AData[0], Length(AData));
|
|
end;
|
|
|
|
function TIptcData.GetImageResourceBlockCount: Integer;
|
|
begin
|
|
Result := FImageResourceBlocks.Count;
|
|
end;
|
|
|
|
function TIptcData.GetTagByID(ATagID: TTagID): TTag;
|
|
var
|
|
idx: Integer;
|
|
begin
|
|
idx := IndexOfTagID(ATagID);
|
|
if idx = -1 then
|
|
Result := nil
|
|
else
|
|
Result := FTagList[idx];
|
|
end;
|
|
|
|
function TIptcData.GetTagByIndex(AIndex: Integer): TTag;
|
|
begin
|
|
Result := FTagList[AIndex];
|
|
end;
|
|
|
|
function TIptcData.GetTagByName(ATagName: String): TTag;
|
|
var
|
|
idx: Integer;
|
|
begin
|
|
idx := IndexOfTagName(ATagName);
|
|
if idx = -1 then
|
|
Result := nil
|
|
else
|
|
Result := FTagList[idx];
|
|
end;
|
|
|
|
function TIptcData.GetTagCount: Integer;
|
|
begin
|
|
Result := FTagList.Count;
|
|
end;
|
|
|
|
function TIptcData.IndexOfTagID(ATagID: TTagID): Integer;
|
|
var
|
|
i: Integer;
|
|
tag: TTag;
|
|
begin
|
|
for i:=0 to FTagList.Count-1 do begin
|
|
tag := FTagList[i];
|
|
if (tag.TagID = ATagID) then begin
|
|
Result := i;
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
function TIptcData.IndexOfTagName(ATagName: String): Integer;
|
|
var
|
|
i: Integer;
|
|
tag: TTag;
|
|
begin
|
|
for i:=0 to FTagList.Count-1 do begin
|
|
tag := FTagList[i];
|
|
if SameText(tag.Name, ATagName) then begin
|
|
Result := i;
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
function TIptcData.InternalAddTag(ATagDef: TTagDef): TTag;
|
|
var
|
|
optns: TTagOptions;
|
|
begin
|
|
if ATagDef <> nil then begin
|
|
optns := [toBigEndian]; //ExportOptionsToTagOptions;
|
|
Result := ATagDef.TagClass.Create(ATagDef, optns);
|
|
AddTag(Result);
|
|
end else
|
|
Result := nil
|
|
end;
|
|
|
|
procedure TIptcData.SetTagByID(ATagID: TTagID; const ATag: TTag);
|
|
var
|
|
idx: Integer;
|
|
begin
|
|
if (ATag <> nil) and ATag.ReadOnly then
|
|
exit;
|
|
|
|
idx := IndexOfTagID(ATagID);
|
|
SetTagByIndex(idx, ATag);
|
|
end;
|
|
|
|
procedure TIptcData.SetTagByIndex(AIndex: Integer; const ATag: TTag);
|
|
var
|
|
tag: TTag;
|
|
begin
|
|
if (ATag <> nil) and ATag.ReadOnly then
|
|
exit;
|
|
|
|
if AIndex > -1 then begin
|
|
tag := FTagList[AIndex];
|
|
if tag.ReadOnly then
|
|
exit;
|
|
FTagList.Delete(AIndex);
|
|
if ATag <> nil then
|
|
FTagList.Insert(AIndex, ATag);
|
|
end else
|
|
AddTag(ATag);
|
|
end;
|
|
|
|
procedure TIptcData.SetTagByName(ATagName: String; const ATag: TTag);
|
|
var
|
|
idx: Integer;
|
|
begin
|
|
if (ATag <> nil) and ATag.ReadOnly then
|
|
exit;
|
|
|
|
idx := IndexOfTagName(ATagName);
|
|
SetTagByIndex(idx, ATag);
|
|
end;
|
|
|
|
|
|
//==============================================================================
|
|
// TIptcStringTag
|
|
//==============================================================================
|
|
constructor TIptcStringTag.Create(ATagDef: TTagDef; AOptions: TTagOptions);
|
|
begin
|
|
inherited Create(ATagDef, AOptions);
|
|
FMaxLen := FCount;
|
|
FCount := 1;
|
|
end;
|
|
|
|
|
|
//==============================================================================
|
|
// TIptcMultiStringTag
|
|
//==============================================================================
|
|
|
|
procedure TIptcMultiStringTag.AddString(const AValue: String);
|
|
var
|
|
s: String;
|
|
mxlen: Integer;
|
|
begin
|
|
s := inherited GetAsString;
|
|
mxlen := Min(MaxInt, FMaxLen);
|
|
if s = '' then
|
|
s := Copy(AValue, 1, mxlen)
|
|
else
|
|
s := s + IPTC_MULTI_TAG_SEPARATOR + Copy(AValue, 1, mxlen);
|
|
inherited SetAsString(s);
|
|
end;
|
|
|
|
function TIptcMultiStringTag.GetAsString: String;
|
|
var
|
|
s: String;
|
|
begin
|
|
s := inherited GetAsString;
|
|
Result := StringReplace(s, IPTC_MULTI_TAG_SEPARATOR, fpExifDataSep, [rfReplaceAll])
|
|
end;
|
|
|
|
procedure TIptcMultiStringTag.SetAsString(const AValue: String);
|
|
var
|
|
sArr: TStringArray;
|
|
i: Integer;
|
|
begin
|
|
inherited SetAsString('');
|
|
if AValue <> '' then begin
|
|
sArr := Split(AValue, fpExifDataSep);
|
|
for i:=0 to High(sArr) do
|
|
AddString(sArr[i]);
|
|
end;
|
|
end;
|
|
|
|
|
|
//==============================================================================
|
|
// TIptcObjectAttrTag
|
|
//==============================================================================
|
|
|
|
procedure TIptcObjectAttrTag.AddString(const AValue: String);
|
|
begin
|
|
|
|
|
|
//!!!!!!!!!!!!!!!
|
|
(*
|
|
if (Length(AValue) < 4) or (AValue[4] <> ':') or not TryStrToInt(Copy(AValue, 1, 3), n) then
|
|
raise EFpExif.Create('Tag "ObjectAttr" must constist of 3 numeric characters, '+
|
|
'a colon and an optional description of max 64 characters');
|
|
*)
|
|
|
|
inherited AddString(AValue);
|
|
end;
|
|
|
|
|
|
//==============================================================================
|
|
// TIptcUrgencyTag
|
|
//==============================================================================
|
|
|
|
procedure TIptcUrgencyTag.SetAsString(const AValue: String);
|
|
var
|
|
n: Integer;
|
|
ok: Boolean;
|
|
begin
|
|
if (AValue <> '') then begin
|
|
n := 0;
|
|
ok := TryStrToInt(AValue, n);
|
|
if (not ok) or (n < 0) or (n > 9) then
|
|
raise EFpExif.Create('Tag "Urgency" can only contain one numeric character 0..9');
|
|
end;
|
|
inherited SetAsString(AValue);
|
|
end;
|
|
|
|
|
|
//==============================================================================
|
|
// TIptcDateTag
|
|
//==============================================================================
|
|
|
|
function TIptcDateTag.GetAsDate: TDateTime;
|
|
var
|
|
s: String;
|
|
y, m, d: String;
|
|
begin
|
|
s := inherited GetAsString;
|
|
if Length(s) >= 8 then begin
|
|
y := Copy(s, 1, 4);
|
|
m := Copy(s, 5, 2);
|
|
d := Copy(s, 7, 2);
|
|
Result := EncodeDate(StrToInt(y), StrToInt(m), StrToInt(d));
|
|
end else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TIptcDateTag.GetAsString: String;
|
|
begin
|
|
Result := FormatDateTime(GetFormat, GetAsDate);
|
|
end;
|
|
|
|
function TIptcDateTag.GetFormat: String;
|
|
begin
|
|
Result := IfThen(FFormatStr = '', fpExifFmtSettings.ShortDateFormat, FFormatStr);
|
|
end;
|
|
|
|
procedure TIptcDateTag.SetAsDate(const AValue: TDateTime);
|
|
begin
|
|
inherited SetAsString(FormatDateTime(IPTC_DATE_FORMAT, AValue));
|
|
end;
|
|
|
|
procedure TIptcDateTag.SetAsString(const AValue: String);
|
|
var
|
|
d: TDateTime;
|
|
fmt: String;
|
|
{$IFNDEF FPC}
|
|
fs: TFormatSettings;
|
|
{$ENDIF}
|
|
begin
|
|
fmt := GetFormat;
|
|
if fmt = IPTC_DATE_FORMAT then
|
|
d := IptcDateStrToDate(AValue)
|
|
else begin
|
|
{$IFDEF FPC}
|
|
d := ScanDateTime(fmt, AValue);
|
|
{$ELSE}
|
|
fs := fpExifFmtSettings;
|
|
fs.ShortDateFormat := fmt;
|
|
fs.LongDateFormat := fmt;
|
|
if pos(':', fmt) > 0 then
|
|
fs.DateSeparator := ':'
|
|
else if pos('.', fmt) > 0 then
|
|
fs.DateSeparator := '.'
|
|
else if pos('/', fmt) > 0 then
|
|
fs.DateSeparator := '/'
|
|
else if pos('-', fmt) > 0 then
|
|
fs.DateSeparator := '-'
|
|
else
|
|
fs.DateSeparator := ' ';
|
|
d := StrToDate(AValue, fs);
|
|
{$ENDIF}
|
|
end;
|
|
SetAsDate(d);
|
|
end;
|
|
|
|
|
|
//==============================================================================
|
|
// TIptcTimeTag
|
|
//==============================================================================
|
|
|
|
function TIptcTimeTag.GetAsString: String;
|
|
begin
|
|
Result := FormatDateTime(GetFormat, GetAsTime);
|
|
end;
|
|
|
|
function TIptcTimeTag.GetFormat: String;
|
|
begin
|
|
Result := IfThen(FFormatStr = '', fpExifFmtSettings.LongTimeformat, FFormatStr);
|
|
end;
|
|
|
|
function TIptcTimeTag.GetAsTime: TDateTime;
|
|
var
|
|
s: String;
|
|
hr, mn, sec: String;
|
|
begin
|
|
s := inherited GetAsString;
|
|
if Length(s) >= 6 then begin
|
|
hr := Copy(s, 1, 2);
|
|
mn := Copy(s, 3, 2);
|
|
sec := Copy(s, 5, 2);
|
|
Result := EncodeTime(StrToInt(hr), StrToInt(mn), StrToInt(sec), 0);
|
|
end else
|
|
Result := 0;
|
|
end;
|
|
|
|
procedure TIptcTimeTag.SetAsString(const AValue: String);
|
|
var
|
|
t: TDateTime;
|
|
fmt: String;
|
|
{$IFNDEF FPC}
|
|
fs: TFormatSettings;
|
|
{$ENDIF}
|
|
begin
|
|
fmt := GetFormat;
|
|
if fmt = IPTC_TIME_FORMAT then
|
|
t := IptcTimeStrToTime(AValue)
|
|
else begin
|
|
{$IFDEF FPC}
|
|
t := ScanDateTime(fmt, AValue);
|
|
{$ELSE}
|
|
fs := fpExifFmtSettings;
|
|
fs.LongTimeFormat := GetFormat;
|
|
t := StrToTime(AValue, fs);
|
|
{$ENDIF}
|
|
end;
|
|
SetAsTime(t);
|
|
end;
|
|
|
|
procedure TIptcTimeTag.SetAsTime(const AValue: TDateTime);
|
|
var
|
|
s: String;
|
|
begin
|
|
s := FormatDateTime(IPTC_TIME_FORMAT, AValue) + LocalTimeZoneStr;
|
|
inherited SetAsString(s);
|
|
end;
|
|
|
|
|
|
initialization
|
|
|
|
finalization
|
|
FreeIptcTagDefs;
|
|
|
|
end.
|