Changeset 31 for trunk/UContact.pas


Ignore:
Timestamp:
Nov 25, 2021, 1:18:44 AM (3 years ago)
Author:
chronos
Message:
  • Modified: Store contact properties in general way to support also user defined properties and unknown attributes.
  • Added: Show contact image in contact edit window.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/UContact.pas

    r30 r31  
    66
    77uses
    8   Classes, SysUtils, fgl, Dialogs, UDataFile, LazUTF8, base64;
     8  Classes, SysUtils, fgl, Dialogs, UDataFile, LazUTF8, Base64;
    99
    1010type
    … …  
    1616
    1717  TContactFieldIndex = (cfFirstName, cfMiddleName, cfLastName, cfTitleBefore,
    18     cfTitleAfter, cfFullName, cfTelPrefCell,
    19     cfTelCell, cfTelHome, cfTelHome2, cfTelWork, cfTelVoip,
    20     cfTelPrefWorkVoice, cfTelPrefHomeVoice, cfTelHomeVoice, cfTelWorkVoice,
    21     cfTelVoice, cfTelMain,
     18    cfTitleAfter, cfFullName, cfTelCell, cfTelHome, cfTelHome2, cfTelWork, cfTelVoip,
     19    cfTelMain, cfEmail,
    2220    cfEmailHome, cfEmailInternet, cfNickName, cfNote, cfRole, cfTitle,
    2321    cfCategories, cfOrganization, cfAdrHome, cfHomeAddressStreet,
    2422    cfHomeAddressCity, cfHomeAddressCountry, cfXTimesContacted,
    25     cfXLastTimeContacted, cfPhoto, cfXJabber);
     23    cfXLastTimeContacted, cfPhoto, cfXJabber, cfDayOfBirth, cfRevision,
     24    cfVersion);
    2625
    2726  TContactField = class
     27    SysName: string;
     28    Groups: TStringArray;
     29    Title: string;
     30    Index: TContactFieldIndex;
     31    ValueIndex: Integer;
     32    DataType: TDataType;
     33  end;
     34
     35  { TContactFields }
     36
     37  TContactFields = class(TFPGObjectList<TContactField>)
     38    function AddNew(Name: string; Groups: TStringArray; Title: string; Index: TContactFieldIndex; DataType:
     39      TDataType; ValueIndex: Integer = -1): TContactField;
     40    function GetByIndex(Index: TContactFieldIndex): TContactField;
     41    procedure LoadToStrings(AItems: TStrings);
     42  end;
     43
     44  { TContactProperty }
     45
     46  TContactProperty = class
    2847    Name: string;
    29     Index: TContactFieldIndex;
    30     DataType: TDataType;
    31   end;
    32 
    33   { TContactFields }
    34 
    35   TContactFields = class(TFPGObjectList<TContactField>)
    36     function AddNew(Name: string; Index: TContactFieldIndex; DataType:
    37       TDataType): TContactField;
    38     procedure LoadToStrings(AItems: TStrings);
     48    Attributes: TStringList;
     49    Values: TStringList;
     50    Encoding: string;
     51    Charset: string;
     52    procedure EvaluateAttributes;
     53    function GetDecodedValue: string;
     54    function MatchNameGroups(AName: string; Groups: TStringArray): Boolean;
     55    procedure Assign(Source: TContactProperty);
     56    constructor Create;
     57    destructor Destroy; override;
     58  end;
     59
     60  { TContactProperties }
     61
     62  TContactProperties = class(TFPGObjectList<TContactProperty>)
     63    function GetByName(Name: string): TContactProperty;
     64    function GetByNameGroups(Name: string; Groups: TStringArray): TContactProperty;
     65    function GetByNameGroupsMultiple(Name: string; Groups: TStringArray): TContactProperties;
    3966  end;
    4067
    … …  
    4673    procedure SetField(Index: TContactFieldIndex; AValue: string);
    4774  public
     75    Properties: TContactProperties;
    4876    Parent: TContactsFile;
    49     Version: string;
    50     FirstName: string;
    51     MiddleName: string;
    52     LastName: string;
    53     TitleBefore: string;
    54     TitleAfter: string;
    55     FullName: string;
    56     TelPrefCell: string;
    57     TelCell: string;
    58     TelHome: string;
    59     TelHome2: string;
    60     TelWork: string;
    61     TelVoip: string;
    62     TelPrefWorkVoice: string;
    63     TelPrefHomeVoice: string;
    64     TelHomeVoice: string;
    65     TelWorkVoice: string;
    66     TelVoice: string;
    67     TelMain: string;
    68     EmailHome: string;
    69     EmailInternet: string;
    70     NickName: string;
    71     Note: string;
    72     Role: string;
    73     Title: string;
    74     Categories: string;
    75     Organization: string;
    76     AdrHome: string;
    77     HomeAddressStreet: string;
    78     HomeAddressCity: string;
    79     HomeAddressCountry: string;
    80     XTimesContacted: string;
    81     XLastTimeContacted: string;
    82     Photo: string;
    83     XJabber: string;
     77    function GetProperty(Index: TContactFieldIndex): TContactProperty;
    8478    procedure Assign(Source: TContact);
    8579    function UpdateFrom(Source: TContact): Boolean;
     80    constructor Create;
     81    destructor Destroy; override;
    8682    property Fields[Index: TContactFieldIndex]: string read GetField write SetField;
    8783  end;
    … …  
    10197  private
    10298    FOnError: TErrorEvent;
    103     function GetNext(var Text: string; Separator: string): string;
    10499    procedure InitFields;
    105100    procedure Error(Text: string; Line: Integer);
     101    function NewItem(Key, Value: string): string;
    106102  public
    107103    Fields: TContactFields;
    … …  
    126122  SFoundPropertiesBeforeBlockStart = 'Found properties before the start of block';
    127123  SFoundBlockEndWithoutBlockStart = 'Found block end without block start';
    128 
    129 { TContacts }
    130 
    131 function TContacts.AddNew: TContact;
    132 begin
    133   Result := TContact.Create;
    134   Result.Parent := ContactsFile;
    135   Add(Result);
    136 end;
    137 
    138 function TContacts.Search(FullName: string): TContact;
    139 var
    140   Contact: TContact;
    141 begin
    142   Result := nil;
    143   for Contact in Self do
    144     if Contact.FullName = FullName then begin
    145       Result := Contact;
    146       Break;
    147     end;
    148 end;
    149 
    150 function TContacts.ToString: ansistring;
    151 var
    152   I: Integer;
    153 begin
    154   Result := '';
    155   for I := 0 to Count - 1 do begin
    156     if I > 0 then Result := Result + ', ';
    157     Result := Result + TContact(Items[I]).FullName;
    158   end;
    159 end;
    160 
    161 { TContactFields }
    162 
    163 function TContactFields.AddNew(Name: string; Index: TContactFieldIndex;
    164   DataType: TDataType): TContactField;
    165 begin
    166   Result := TContactField.Create;
    167   Result.Name := Name;
    168   Result.Index := Index;
    169   Result.DataType := DataType;
    170   Add(Result);
    171 end;
    172 
    173 procedure TContactFields.LoadToStrings(AItems: TStrings);
    174 var
    175   I: Integer;
    176 begin
    177   while AItems.Count < Count do AItems.Add('');
    178   while AItems.Count > Count do AItems.Delete(AItems.Count - 1);
    179   for I := 0 to Count - 1 do
    180     AItems[I] := TContactField(Items[I]).Name;
    181 end;
    182 
    183 { TContact }
    184 
    185 function TContact.GetField(Index: TContactFieldIndex): string;
    186 begin
    187   case Index of
    188     cfFirstName: Result := FirstName;
    189     cfMiddleName: Result := MiddleName;
    190     cfLastName: Result := LastName;
    191     cfTitleBefore: Result := TitleBefore;
    192     cfTitleAfter: Result := TitleAfter;
    193     cfFullName: Result := FullName;
    194     cfTelPrefCell: Result := TelPrefCell;
    195     cfTelCell: Result := TelCell;
    196     cfTelHome: Result := TelHome;
    197     cfTelHome2: Result := TelHome2;
    198     cfTelWork: Result := TelWork;
    199     cfTelVoip: Result := TelVoip;
    200     cfTelPrefWorkVoice: Result := TelPrefWorkVoice;
    201     cfTelPrefHomeVoice: Result := TelPrefHomeVoice;
    202     cfTelHomeVoice: Result := TelHomeVoice;
    203     cfTelWorkVoice: Result := TelWorkVoice;
    204     cfTelVoice: Result := TelVoice;
    205     cfTelMain: Result := TelMain;
    206     cfEmailHome: Result := EmailHome;
    207     cfEmailInternet: Result := EmailInternet;
    208     cfNickName: Result := NickName;
    209     cfNote: Result := Note;
    210     cfRole: Result := Role;
    211     cfTitle: Result := Title;
    212     cfCategories: Result := Categories;
    213     cfOrganization: Result := Organization;
    214     cfAdrHome: Result := AdrHome;
    215     cfHomeAddressStreet: Result := HomeAddressStreet;
    216     cfHomeAddressCity: Result := HomeAddressCity;
    217     cfHomeAddressCountry: Result := HomeAddressCountry;
    218     cfXTimesContacted: Result := XTimesContacted;
    219     cfXLastTimeContacted: Result := XLastTimeContacted;
    220     cfPhoto: Result := Photo;
    221     cfXJabber: Result := XJabber;
    222     else raise Exception.Create(SUnsupportedContactFieldsIndex);
    223   end;
    224 end;
    225 
    226 procedure TContact.SetField(Index: TContactFieldIndex; AValue: string);
    227 begin
    228   case Index of
    229     cfFirstName: FirstName := AValue;
    230     cfMiddleName: MiddleName := AValue;
    231     cfLastName: LastName := AValue;
    232     cfTitleBefore: TitleBefore := AValue;
    233     cfTitleAfter: TitleAfter := AValue;
    234     cfFullName: FullName := AValue;
    235     cfTelPrefCell: TelPrefCell := AValue;
    236     cfTelCell: TelCell := AValue;
    237     cfTelHome: TelHome := AValue;
    238     cfTelHome2: TelHome2 := AValue;
    239     cfTelWork: TelWork := AValue;
    240     cfTelVoip: TelVoip := AValue;
    241     cfTelPrefWorkVoice: TelPrefWorkVoice := AValue;
    242     cfTelPrefHomeVoice: TelPrefHomeVoice := AValue;
    243     cfTelHomeVoice: TelHomeVoice := AValue;
    244     cfTelWorkVoice: TelWorkVoice := AValue;
    245     cfTelVoice: TelVoice := AValue;
    246     cfTelMain: TelMain := AValue;
    247     cfEmailHome: EmailHome := AValue;
    248     cfEmailInternet: EmailInternet := AValue;
    249     cfNickName: NickName := AValue;
    250     cfNote: Note := AValue;
    251     cfRole: Role := AValue;
    252     cfTitle: Title := AValue;
    253     cfCategories: Categories := AValue;
    254     cfOrganization: Organization := AValue;
    255     cfAdrHome: AdrHome := AValue;
    256     cfHomeAddressStreet: HomeAddressStreet := AValue;
    257     cfHomeAddressCity: HomeAddressCity := AValue;
    258     cfHomeAddressCountry: HomeAddressCountry := AValue;
    259     cfXTimesContacted: XTimesContacted := AValue;
    260     cfXLastTimeContacted: XLastTimeContacted := AValue;
    261     cfPhoto: Photo := AValue;
    262     cfXJabber: XJabber := AValue;
    263     else raise Exception.Create(SUnsupportedContactFieldsIndex);
    264   end;
    265 end;
    266 
    267 procedure TContact.Assign(Source: TContact);
    268 begin
    269   Version := Source.Version;
    270   FirstName := Source.FirstName;
    271   MiddleName := Source.MiddleName;
    272   LastName := Source.LastName;
    273   TitleBefore := Source.TitleBefore;
    274   TitleAfter := Source.TitleAfter;
    275   FullName := Source.FullName;
    276   TelPrefCell := Source.TelPrefCell;
    277   TelCell := Source.TelCell;
    278   TelHome := Source.TelHome;
    279   TelHome2 := Source.TelHome2;
    280   TelWork := Source.TelWork;
    281   TelVoip := Source.TelVoip;
    282   TelPrefWorkVoice := Source.TelPrefWorkVoice;
    283   TelPrefHomeVoice := Source.TelPrefHomeVoice;
    284   TelHomeVoice := Source.TelHomeVoice;
    285   TelWorkVoice := Source.TelWorkVoice;
    286   EmailHome := Source.EmailHome;
    287   EmailInternet := Source.EmailInternet;
    288   NickName := Source.NickName;
    289   Note := Source.Note;
    290   Role := Source.Role;
    291   Title := Source.Title;
    292   Categories := Source.Categories;
    293   Organization := Source.Organization;
    294   AdrHome := Source.AdrHome;
    295   HomeAddressStreet := Source.HomeAddressStreet;
    296   HomeAddressCity := Source.HomeAddressCity;
    297   HomeAddressCountry := Source.HomeAddressCountry;
    298   XTimesContacted := Source.XTimesContacted;
    299   XLastTimeContacted := Source.XLastTimeContacted;
    300   Photo := Source.Photo;
    301   XJabber := Source.XJabber;
    302 end;
    303 
    304 function TContact.UpdateFrom(Source: TContact): Boolean;
    305 var
    306   I: Integer;
    307 begin
    308   Result := False;
    309   for I := 0 to Parent.Fields.Count - 1 do begin
    310     if (Source.Fields[TContactField(Parent.Fields[I]).Index] <> '') and
    311       (Source.Fields[TContactField(Parent.Fields[I]).Index] <>
    312       Fields[TContactField(Parent.Fields[I]).Index]) then begin
    313         Result := True;
    314         Fields[TContactField(Parent.Fields[I]).Index] := Source.Fields[TContactField(Parent.Fields[I]).Index];
    315       end;
    316   end;
    317 end;
    318 
    319 { TContactsFile }
    320 
    321 function TContactsFile.GetNext(var Text: string; Separator: string): string;
     124  SFieldIndexNotDefined = 'Field index not defined';
     125
     126function GetNext(var Text: string; Separator: string): string;
    322127begin
    323128  if Pos(Separator, Text) > 0 then begin
    … …  
    330135end;
    331136
    332 procedure TContactsFile.InitFields;
    333 begin
    334   with Fields do begin
    335     AddNew('First Name', cfFirstName, dtString);
    336     AddNew('Middle Name', cfMiddleName, dtString);
    337     AddNew('Last Name', cfLastName, dtString);
    338     AddNew('Title Before', cfTitleBefore, dtString);
    339     AddNew('Title After', cfTitleAfter, dtString);
    340     AddNew('Full Name', cfFullName, dtString);
    341     AddNew('Preferred cell phone', cfTelPrefCell, dtString);
    342     AddNew('Cell phone', cfTelCell, dtString);
    343     AddNew('Home phone', cfTelHome, dtString);
    344     AddNew('Home phone 2', cfTelHome2, dtString);
    345     AddNew('Home work', cfTelWork, dtString);
    346     AddNew('Tel Voip', cfTelVoip, dtString);
    347     AddNew('Tel Pref Work Voice', cfTelPrefWorkVoice, dtString);
    348     AddNew('Tel Pref Home Voice', cfTelPrefHomeVoice, dtString);
    349     AddNew('Tel Home Voice', cfTelHomeVoice, dtString);
    350     AddNew('Tel Work Voice', cfTelWorkVoice, dtString);
    351     AddNew('Tel Voice', cfTelVoice, dtString);
    352     AddNew('Tel Main', cfTelMain, dtString);
    353     AddNew('Email Home', cfEmailHome, dtString);
    354     AddNew('Email Internet', cfEmailInternet, dtString);
    355     AddNew('Nick Name', cfNickName, dtString);
    356     AddNew('Note', cfNote, dtString);
    357     AddNew('Role', cfRole, dtString);
    358     AddNew('Title', cfTitle, dtString);
    359     AddNew('Categories', cfCategories, dtString);
    360     AddNew('Organization', cfOrganization, dtString);
    361     AddNew('Home Address', cfAdrHome, dtString);
    362     AddNew('Home Address Street', cfHomeAddressStreet, dtString);
    363     AddNew('Home Address City', cfHomeAddressCity, dtString);
    364     AddNew('Home Address Country', cfHomeAddressCountry, dtString);
    365     AddNew('Times Contacted', cfXTimesContacted, dtString);
    366     AddNew('Last Time Contacted', cfXLastTimeContacted, dtString);
    367     AddNew('Photo', cfPhoto, dtString);
    368     AddNew('Jabber', cfXJabber, dtString);
    369   end;
    370 end;
    371 
    372 procedure TContactsFile.Error(Text: string; Line: Integer);
    373 begin
    374   if Assigned(FOnError) then FOnError(Text, Line);
    375 end;
    376 
    377 function TContactsFile.GetFileName: string;
    378 begin
    379   Result := SVCardFile;
    380 end;
    381 
    382 function TContactsFile.GetFileExt: string;
    383 begin
    384   Result := '.vcf';
    385 end;
    386 
    387 function TContactsFile.GetFileFilter: string;
    388 begin
    389   Result := GetFileName + ' (' + GetFileExt + ')|*' + GetFileExt + '|' + inherited;
    390 end;
    391 
    392 procedure TContactsFile.SaveToFile(FileName: string);
    393 var
    394   Output: TStringList;
    395   I: Integer;
    396   PhotoBase64: string;
    397   Line: string;
    398 
    399137function IsAsciiString(Text: string): Boolean;
    400138var
    … …  
    409147end;
    410148
    411 function NewItem(Key, Value: string): string;
     149{ TContactProperties }
     150
     151function TContactProperties.GetByName(Name: string): TContactProperty;
     152var
     153  I: Integer;
     154begin
     155  I := 0;
     156  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
     157  if I < Count then Result := Items[I]
     158    else Result := nil;
     159end;
     160
     161function TContactProperties.GetByNameGroups(Name: string; Groups: TStringArray
     162  ): TContactProperty;
     163var
     164  I: Integer;
     165begin
     166  I := 0;
     167  while (I < Count) and not Items[I].MatchNameGroups(Name, Groups) do Inc(I);
     168  if I < Count then Result := Items[I]
     169    else Result := nil;
     170end;
     171
     172function TContactProperties.GetByNameGroupsMultiple(Name: string;
     173  Groups: TStringArray): TContactProperties;
     174var
     175  I: Integer;
     176begin
     177  Result := TContactProperties.Create(False);
     178  for I := 0 to Count - 1 do
     179  if Items[I].MatchNameGroups(Name, Groups) then
     180    Result.Add(Items[I]);
     181end;
     182
     183{ TContactProperty }
     184
     185procedure TContactProperty.EvaluateAttributes;
     186begin
     187  if Attributes.IndexOfName('ENCODING') <> -1 then
     188    Encoding := Attributes.Values['ENCODING']
     189    else Encoding := '';
     190  if Attributes.IndexOfName('CHARSET') <> -1 then
     191    Charset := Attributes.Values['CHARSET']
     192    else Charset := '';
     193end;
     194
     195function TContactProperty.GetDecodedValue: string;
     196begin
     197  if Encoding = 'BASE64' then
     198    Result := DecodeStringBase64(Values.DelimitedText)
     199  else
     200  if Encoding = 'QUOTED-PRINTABLE' then
     201    Result := Values.DelimitedText
     202  else Result := '';
     203end;
     204
     205function TContactProperty.MatchNameGroups(AName: string; Groups: TStringArray
     206  ): Boolean;
     207var
     208  I: Integer;
     209begin
     210  Result := Name = AName;
     211  if Result then begin
     212    for I := 0 to Length(Groups) - 1 do
     213      if Attributes.IndexOf(Groups[I]) = -1 then begin
     214        Result := False;
     215        Break;
     216      end;
     217  end;
     218end;
     219
     220procedure TContactProperty.Assign(Source: TContactProperty);
     221begin
     222  Name := Source.Name;
     223  Attributes.Assign(Source.Attributes);
     224  Values.Assign(Source.Values);
     225end;
     226
     227constructor TContactProperty.Create;
     228begin
     229  Attributes := TStringList.Create;
     230  Attributes.Delimiter := ';';
     231  Attributes.NameValueSeparator := '=';
     232  Attributes.StrictDelimiter := True;
     233  Values := TStringList.Create;
     234  Values.Delimiter := ';';
     235  Values.NameValueSeparator := '=';
     236  Values.StrictDelimiter := True;
     237end;
     238
     239destructor TContactProperty.Destroy;
     240begin
     241  FreeAndNil(Values);
     242  FreeAndNil(Attributes);
     243  inherited;
     244end;
     245
     246{ TContacts }
     247
     248function TContacts.AddNew: TContact;
     249begin
     250  Result := TContact.Create;
     251  Result.Parent := ContactsFile;
     252  Add(Result);
     253end;
     254
     255function TContacts.Search(FullName: string): TContact;
     256var
     257  Contact: TContact;
     258begin
     259  Result := nil;
     260  for Contact in Self do
     261    if Contact.Fields[cfFullName] = FullName then begin
     262      Result := Contact;
     263      Break;
     264    end;
     265end;
     266
     267function TContacts.ToString: ansistring;
     268var
     269  I: Integer;
     270begin
     271  Result := '';
     272  for I := 0 to Count - 1 do begin
     273    if I > 0 then Result := Result + ', ';
     274    Result := Result + Items[I].Fields[cfFullName];
     275  end;
     276end;
     277
     278{ TContactFields }
     279
     280function TContactFields.AddNew(Name: string; Groups: TStringArray; Title: string; Index: TContactFieldIndex;
     281  DataType: TDataType; ValueIndex: Integer = -1): TContactField;
     282begin
     283  Result := TContactField.Create;
     284  Result.SysName := Name;
     285  Result.Groups := Groups;
     286  Result.Title := Title;
     287  Result.Index := Index;
     288  Result.ValueIndex := ValueIndex;
     289  Result.DataType := DataType;
     290  Add(Result);
     291end;
     292
     293function TContactFields.GetByIndex(Index: TContactFieldIndex): TContactField;
     294var
     295  I: Integer;
     296begin
     297  I := 0;
     298  while (I < Count) and (Items[I].Index <> Index) do Inc(I);
     299  if I < Count then Result := Items[I]
     300    else Result := nil;
     301end;
     302
     303procedure TContactFields.LoadToStrings(AItems: TStrings);
     304var
     305  I: Integer;
     306begin
     307  while AItems.Count < Count do AItems.Add('');
     308  while AItems.Count > Count do AItems.Delete(AItems.Count - 1);
     309  for I := 0 to Count - 1 do
     310    AItems[I] := Items[I].Title;
     311end;
     312
     313{ TContact }
     314
     315function TContact.GetField(Index: TContactFieldIndex): string;
     316var
     317  Prop: TContactProperty;
     318  Field: TContactField;
     319begin
     320  Prop := GetProperty(Index);
     321  if Assigned(Prop) then begin
     322    Field := Parent.Fields.GetByIndex(Index);
     323    if Field.ValueIndex <> -1 then begin
     324      if Field.ValueIndex < Prop.Values.Count then
     325        Result := Prop.Values.Strings[Field.ValueIndex]
     326        else Result := '';
     327    end else Result := Prop.Values.DelimitedText;
     328  end else Result := '';
     329end;
     330
     331procedure TContact.SetField(Index: TContactFieldIndex; AValue: string);
     332var
     333  Prop: TContactProperty;
     334  Field: TContactField;
     335  I: Integer;
     336begin
     337  Field := Parent.Fields.GetByIndex(Index);
     338  if Assigned(Field) then begin
     339    Prop := Properties.GetByNameGroups(Field.SysName, Field.Groups);
     340    if not Assigned(Prop) then begin
     341      Prop := TContactProperty.Create;
     342      Prop.Name := Field.SysName;
     343      for I := 0 to Length(Field.Groups) - 1 do
     344        Prop.Attributes.Add(Field.Groups[I]);
     345      Properties.Add(Prop);
     346    end;
     347    if Field.ValueIndex <> -1 then begin
     348      while Prop.Values.Count <= Field.ValueIndex do Prop.Values.Add('');
     349      Prop.Values.Strings[Field.ValueIndex] := AValue
     350    end else Prop.Values.DelimitedText := AValue;
     351  end else raise Exception.Create(SFieldIndexNotDefined);
     352end;
     353
     354function TContact.GetProperty(Index: TContactFieldIndex): TContactProperty;
     355var
     356  Prop: TContactProperty;
     357  Field: TContactField;
     358begin
     359  Field := Parent.Fields.GetByIndex(Index);
     360  if Assigned(Field) then begin
     361    Result := Properties.GetByNameGroups(Field.SysName, Field.Groups);
     362  end else raise Exception.Create(SFieldIndexNotDefined);
     363end;
     364
     365procedure TContact.Assign(Source: TContact);
     366begin
     367  Properties.Assign(Source.Properties);
     368end;
     369
     370function TContact.UpdateFrom(Source: TContact): Boolean;
     371var
     372  I: Integer;
     373begin
     374  Result := False;
     375  for I := 0 to Parent.Fields.Count - 1 do begin
     376    if (Source.Fields[Parent.Fields[I].Index] <> '') and
     377      (Source.Fields[Parent.Fields[I].Index] <>
     378      Fields[Parent.Fields[I].Index]) then begin
     379        Result := True;
     380        Fields[Parent.Fields[I].Index] := Source.Fields[Parent.Fields[I].Index];
     381      end;
     382  end;
     383end;
     384
     385constructor TContact.Create;
     386begin
     387  Properties := TContactProperties.Create;
     388end;
     389
     390destructor TContact.Destroy;
     391begin
     392  FreeAndNil(Properties);
     393  inherited;
     394end;
     395
     396{ TContactsFile }
     397
     398procedure TContactsFile.InitFields;
     399begin
     400  with Fields do begin
     401    AddNew('N', [], 'Last Name', cfLastName, dtString, 0);
     402    AddNew('N', [], 'First Name', cfFirstName, dtString, 1);
     403    AddNew('N', [], 'Middle Name', cfMiddleName, dtString, 2);
     404    AddNew('N', [], 'Title Before', cfTitleBefore, dtString, 3);
     405    AddNew('N', [], 'Title After', cfTitleAfter, dtString, 4);
     406    AddNew('FN', [], 'Full Name', cfFullName, dtString);
     407    AddNew('TEL', ['CELL'], 'Cell phone', cfTelCell, dtString);
     408    AddNew('TEL', ['HOME'], 'Home phone', cfTelHome, dtString);
     409    AddNew('TEL', ['HOME2'], 'Home phone 2', cfTelHome2, dtString);
     410    AddNew('TEL', ['WORK'], 'Home work', cfTelWork, dtString);
     411    AddNew('TEL', ['VOIP'], 'Tel VoIP', cfTelVoip, dtString);
     412    AddNew('TEL', ['MAIN'], 'Tel Main', cfTelMain, dtString);
     413    AddNew('EMAIL', [], 'Email', cfEmail, dtString);
     414    AddNew('EMAIL', ['HOME'], 'Email Home', cfEmailHome, dtString);
     415    AddNew('EMAIL', ['INTERNET'], 'Email Internet', cfEmailInternet, dtString);
     416    AddNew('X-NICKNAME', [], 'Nick Name', cfNickName, dtString);
     417    AddNew('NOTE', [], 'Note', cfNote, dtString);
     418    AddNew('ROLE', [], 'Role', cfRole, dtString);
     419    AddNew('TITLE', [], 'Title', cfTitle, dtString);
     420    AddNew('CATEGORIES', [], 'Categories', cfCategories, dtString);
     421    AddNew('ORG', [], 'Organization', cfOrganization, dtString);
     422    AddNew('ADR', ['HOME'], 'Home Address', cfAdrHome, dtString);
     423    AddNew('ADR', ['HOME'], 'Home Address Street', cfHomeAddressStreet, dtString, 1);
     424    AddNew('ADR', ['HOME'], 'Home Address City', cfHomeAddressCity, dtString, 2);
     425    AddNew('ADR', ['HOME'], 'Home Address Country', cfHomeAddressCountry, dtString, 3);
     426    AddNew('X-TIMES_CONTACTED', [], 'Times Contacted', cfXTimesContacted, dtString);
     427    AddNew('X-LAST_TIME_CONTACTED', [], 'Last Time Contacted', cfXLastTimeContacted, dtString);
     428    AddNew('PHOTO', [], 'Photo', cfPhoto, dtString);
     429    AddNew('X-JABBER', [], 'Jabber', cfXJabber, dtString);
     430    AddNew('BDAY', [], 'Day of birth', cfDayOfBirth, dtString);
     431    AddNew('REV', [], 'Revision', cfRevision, dtString);
     432  end;
     433end;
     434
     435procedure TContactsFile.Error(Text: string; Line: Integer);
     436begin
     437  if Assigned(FOnError) then FOnError(Text, Line);
     438end;
     439
     440function TContactsFile.GetFileName: string;
     441begin
     442  Result := SVCardFile;
     443end;
     444
     445function TContactsFile.GetFileExt: string;
     446begin
     447  Result := '.vcf';
     448end;
     449
     450function TContactsFile.GetFileFilter: string;
     451begin
     452  Result := GetFileName + ' (' + GetFileExt + ')|*' + GetFileExt + '|' + inherited;
     453end;
     454
     455function TContactsFile.NewItem(Key, Value: string): string;
    412456var
    413457  Charset: string;
    … …  
    418462end;
    419463
     464procedure TContactsFile.SaveToFile(FileName: string);
     465var
     466  Output: TStringList;
     467  I: Integer;
     468  J: Integer;
     469  Value: string;
     470  NameText: string;
    420471begin
    421472  inherited;
    … …  
    423474    Output := TStringList.Create;
    424475    for I := 0 to Contacts.Count - 1 do
    425     with TContact(Contacts[I]), Output do begin
     476    with Contacts[I], Output do begin
    426477      Add('BEGIN:VCARD');
    427       if Version <> '' then Add('VERSION:' + Version);
    428       if XTimesContacted <> '' then Add('X-TIMES_CONTACTED:' + XTimesContacted);
    429       if XLastTimeContacted <> '' then Add('X-LAST_TIME_CONTACTED:' + XLastTimeContacted);
    430       if (LastName <> '') or (FirstName <> '') or (MiddleName <> '') or (TitleBefore <> '') or (TitleAfter <> '') then
    431         Add(NewItem('N', LastName + ';' + FirstName + ';' + MiddleName + ';' + TitleBefore + ';' + TitleAfter));
    432       if FullName <> '' then Add(NewItem('FN', FullName));
    433       if TelCell <> '' then Add('TEL;CELL:' + TelCell);
    434       if TelPrefCell <> '' then Add('TEL;PREF;CELL:' + TelPrefCell);
    435       if TelHome <> '' then Add('TEL;HOME:' + TelHome);
    436       if TelHome2 <> '' then Add('TEL;HOME2:' + TelHome2);
    437       if TelWork <> '' then Add('TEL;WORK:' + TelWork);
    438       if TelVoip <> '' then Add('TEL;VOIP:' + TelVoip);
    439       if TelPrefWorkVoice <> '' then Add('TEL;PREF;WORK;VOICE:' + TelPrefWorkVoice);
    440       if TelPrefHomeVoice <> '' then Add('TEL;PREF;HOME;VOICE:' + TelPrefHomeVoice);
    441       if TelHomeVoice <> '' then Add('TEL;HOME;VOICE:' + TelHomeVoice);
    442       if TelWorkVoice <> '' then Add('TEL;WORK;VOICE:' + TelWorkVoice);
    443       if TelVoice <> '' then Add('TEL;VOICE:' + TelVoice);
    444       if TelMain <> '' then Add('TEL;MAIN:' + TelMain);
    445       if Note <> '' then Add('NOTE:' + Note);
    446       if AdrHome <> '' then Add('ADR;HOME:' + AdrHome);
    447       if EmailHome <> '' then Add('EMAIL;HOME:' + EmailHome);
    448       if NickName <> '' then Add('X-NICKNAME:' + NickName);
    449       if EmailInternet <> '' then Add('EMAIL;INTERNET:' + EmailInternet);
    450       if XJabber <> '' then Add('X-JABBER:' + XJabber);
    451       if Role <> '' then Add('TITLE:' + Role);
    452       if Categories <> '' then Add('CATEGORIES:' + Categories);
    453       if Organization <> '' then Add('ORG:' + Organization);
    454       if (HomeAddressCity <> '') or (HomeAddressStreet <> '') or
    455         (HomeAddressCountry <> '') then Add('ADR;HOME:;;' + HomeAddressStreet + ';' + HomeAddressCity + ';;;' + HomeAddressCountry);
    456       if Photo <> '' then begin
    457         PhotoBase64 := EncodeStringBase64(Photo);
    458 
    459         Line := Copy(PhotoBase64, 1, 73 - Length('PHOTO;ENCODING=BASE64;JPEG:'));
    460         System.Delete(PhotoBase64, 1, Length(Line));
    461         Add('PHOTO;ENCODING=BASE64;JPEG:' + Line);
    462         while PhotoBase64 <> '' do begin
    463           Line := Copy(PhotoBase64, 1, 73);
    464           System.Delete(PhotoBase64, 1, Length(Line));
    465           Add(' ' + Line);
     478      for J := 0 to Properties.Count - 1 do
     479      with Properties[J] do begin
     480        Value := Values.DelimitedText;
     481        if Pos(LineEnding, Value) > 0 then begin
     482          NameText := Name;
     483          if Attributes.Count > 0 then
     484            NameText := NameText + ';' + Attributes.DelimitedText;
     485          Add(NameText + ':' + GetNext(Value, LineEnding));
     486          while Pos(LineEnding, Value) > 0 do begin
     487            Add(' ' + GetNext(Value, LineEnding));
     488          end;
     489          Add(' ' + GetNext(Value, LineEnding));
     490          Add('');
     491        end else begin
     492          NameText := Name;
     493          if Attributes.Count > 0 then
     494            NameText := NameText + ';' + Attributes.DelimitedText;
     495          Add(NameText + ':' + Value);
    466496        end;
    467         Add('');
    468497      end;
    469498      Add('END:VCARD');
    … …  
    479508  Lines: TStringList;
    480509  Line: string;
     510  Value: string;
    481511  I: Integer;
    482512  NewRecord: TContact;
    483   Command: string;
     513  NewProperty: TContactProperty;
    484514  CommandPart: string;
    485   Charset: string;
    486   Encoding: string;
    487   Language: string;
    488   CommandItems: TStringList;
     515  Names: string;
    489516begin
    490517  inherited;
    … …  
    494521  Lines.LoadFromFile(FileName);
    495522  try
    496     CommandItems := TStringList.Create;
    497     CommandItems.Delimiter := ';';
    498523    I := 0;
    499524    while I < Lines.Count do begin
    500525      Line := Lines[I];
     526      if Line = '' then
     527      else
    501528      if Line = 'BEGIN:VCARD' then begin
    502529        NewRecord := TContact.Create;
    … …  
    511538      if Pos(':', Line) > 0 then begin
    512539        CommandPart := GetNext(Line, ':');
    513         CommandItems.DelimitedText := CommandPart;
    514         if CommandItems.IndexOfName('CHARSET') >= 0 then begin
    515           Charset := CommandItems.Values['CHARSET'];
    516           CommandItems.Delete(CommandItems.IndexOfName('CHARSET'));
    517         end
    518         else if CommandItems.IndexOfName('ENCODING') >= 0 then begin
    519           Encoding := CommandItems.Values['ENCODING'];
    520           CommandItems.Delete(CommandItems.IndexOfName('ENCODING'));
    521         end
    522         else if CommandItems.IndexOfName('LANGUAGE') >= 0 then begin
    523           Language := CommandItems.Values['LANGUAGE'];
    524           CommandItems.Delete(CommandItems.IndexOfName('LANGUAGE'));
    525         end;
    526         Command := CommandItems.DelimitedText;
    527 
    528540        if Assigned(NewRecord) then begin
    529           if Command = 'FN' then NewRecord.FullName := Line
    530           else if Command = 'N' then begin
    531             NewRecord.LastName := GetNext(Line, ';');
    532             NewRecord.FirstName := GetNext(Line, ';');
    533             NewRecord.MiddleName := GetNext(Line, ';');
    534             NewRecord.TitleBefore := GetNext(Line, ';');
    535             NewRecord.TitleAfter := GetNext(Line, ';');
    536           end
    537           else if Command = 'VERSION' then NewRecord.Version := Line
    538           else if Command = 'TEL;PREF;CELL' then NewRecord.TelPrefCell := Line
    539           else if Command = 'TEL;CELL' then NewRecord.TelCell := Line
    540           else if Command = 'TEL;HOME' then NewRecord.TelHome := Line
    541           else if Command = 'TEL;HOME2' then NewRecord.TelHome2 := Line
    542           else if Command = 'TEL;WORK' then NewRecord.TelWork := Line
    543           else if Command = 'TEL;VOIP' then NewRecord.TelVoip := Line
    544           else if Command = 'TEL;PREF;WORK;VOICE' then NewRecord.TelPrefWorkVoice := Line
    545           else if Command = 'TEL;PREF;HOME;VOICE' then NewRecord.TelPrefHOMEVoice := Line
    546           else if Command = 'TEL;HOME;VOICE' then NewRecord.TelHomeVoice := Line
    547           else if Command = 'TEL;WORK;VOICE' then NewRecord.TelWorkVoice := Line
    548           else if Command = 'TEL;VOICE' then NewRecord.TelVoice := Line
    549           else if Command = 'TEL;MAIN' then NewRecord.TelMain := Line
    550           else if Command = 'ADR;HOME' then NewRecord.AdrHome := Line
    551           else if Command = 'X-NICKNAME' then NewRecord.NickName := Line
    552           else if Command = 'EMAIL;HOME' then NewRecord.EmailHome := Line
    553           else if Command = 'EMAIL;INTERNET' then NewRecord.EmailInternet := Line
    554           else if Command = 'NOTE' then NewRecord.Note := Line
    555           else if Command = 'ORG' then NewRecord.Organization := Line
    556           else if Command = 'X-JABBER' then NewRecord.XJabber := Line
    557           else if Command = 'TITLE' then NewRecord.Role := Line
    558           else if Command = 'X-TIMES_CONTACTED' then NewRecord.XTimesContacted := Line
    559           else if Command = 'X-LAST_TIME_CONTACTED' then NewRecord.XLastTimeContacted := Line
    560           else if Command = 'PHOTO;JPEG' then begin
    561             NewRecord.Photo := Trim(Line);
    562             repeat
    563               Inc(I);
    564               Line := Trim(Lines[I]);
    565               if Line <> '' then NewRecord.Photo := NewRecord.Photo + Line;
    566             until Line = '';
    567             NewRecord.Photo := DecodeStringBase64(NewRecord.Photo);
    568           end
    569           else Error(Format(SUnknownCommand, [Command]), I + 1);
     541          Names := CommandPart;
     542          Value := Line;
     543          while True do begin
     544            Inc(I);
     545            if (Length(Lines[I]) > 0) and (Lines[I][1] = ' ') then begin
     546              Value := Value + Trim(Lines[I]);
     547            end else begin
     548              Dec(I);
     549              Break;
     550            end;
     551          end;
     552          NewProperty := NewRecord.Properties.GetByName(Names);
     553          if not Assigned(NewProperty) then begin
     554            NewProperty := TContactProperty.Create;
     555            NewRecord.Properties.Add(NewProperty);
     556          end;
     557          NewProperty.Attributes.DelimitedText := Names;
     558          if NewProperty.Attributes.Count > 0 then begin
     559            NewProperty.Name := NewProperty.Attributes[0];
     560            NewProperty.Attributes.Delete(0);
     561          end;
     562          NewProperty.Values.DelimitedText := Value;
     563          NewProperty.EvaluateAttributes;
    570564        end else Error(SFoundPropertiesBeforeBlockStart, I + 1);
    571565      end;
    572566      Inc(I);
    573567    end;
    574     CommandItems.Free;
    575568  finally
    576569    Lines.Free;
Note: See TracChangeset for help on using the changeset viewer.