tvplanit: Import contacts from vCards (*.vcf)

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6475 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/tvplanit/languages/vpsr.de.po

@@ -256,6 +256,10 @@ msgstr "Diese Aufgabe von Ihrer Liste löschen?"
 msgid "Add contact..."
 msgstr "Kontakt hinzufügen..."
 
+#: vpsr.rscontactpopupaddvcards
+msgid "Add contact from vCard(s)..."
+msgstr ""
+
 #: vpsr.rscontactpopupdelete
 msgid "Delete contact..."
 msgstr "Kontakt löschen..."
@@ -577,6 +581,10 @@ msgstr "M"
 msgid "Load file..."
 msgstr "Datei laden..."
 
+#: vpsr.rsloadvcardstitle
+msgid "Load vCard(s)"
+msgstr ""
+
 #: vpsr.rslocation
 msgid "Location"
 msgstr "Ort"
@@ -1115,7 +1123,9 @@ msgid "Error: Unable to update "
 msgstr "Fehler: Kann nicht updaten"
 
 #: vpsr.rsstartendtimeerror
-msgid "Incorrect order of start and end times. Do you want to flip them?"
+#, fuzzy
+#| msgid "Incorrect order of start and end times. Do you want to flip them?"
+msgid "Incorrect order of start and end times. Do you want to exchange them?"
 msgstr "Falsche Reihenfolge der Start- und Ende-Zeit. Wollen Sie die beiden vertauschen?"
 
 #: vpsr.rsstarttimelbl
@@ -1255,6 +1265,10 @@ msgstr "BEMERKUNGEN"
 msgid "WORK"
 msgstr "ARBEIT"
 
+#: vpsr.rsvcardfilter
+msgid "vCard files (*.vcf)|*.vcf"
+msgstr ""
+
 #: vpsr.rsvisible
 msgid "Visible"
 msgstr "Sichtbar"
@@ -1633,3 +1647,4 @@ msgstr "Unbekannte Achsen-Spezifikation: %s"
 #: vpsr.sxmldecnotatbeg
 msgid "The XML declaration must appear before the first element"
 msgstr "Die XML-Deklaration muss vor dem ersten Element erscheinen."
+

components/tvplanit/languages/vpsr.fi.po

@@ -246,6 +246,10 @@ msgstr ""
 msgid "Add contact..."
 msgstr ""
 
+#: vpsr.rscontactpopupaddvcards
+msgid "Add contact from vCard(s)..."
+msgstr ""
+
 #: vpsr.rscontactpopupdelete
 msgid "Delete contact..."
 msgstr ""
@@ -568,6 +572,10 @@ msgstr "M"
 msgid "Load file..."
 msgstr ""
 
+#: vpsr.rsloadvcardstitle
+msgid "Load vCard(s)"
+msgstr ""
+
 #: vpsr.rslocation
 msgid "Location"
 msgstr ""
@@ -1106,7 +1114,7 @@ msgid "Error: Unable to update "
 msgstr ""
 
 #: vpsr.rsstartendtimeerror
-msgid "Incorrect order of start and end times. Do you want to flip them?"
+msgid "Incorrect order of start and end times. Do you want to exchange them?"
 msgstr ""
 
 #: vpsr.rsstarttimelbl
@@ -1247,6 +1255,10 @@ msgstr ""
 msgid "WORK"
 msgstr ""
 
+#: vpsr.rsvcardfilter
+msgid "vCard files (*.vcf)|*.vcf"
+msgstr ""
+
 #: vpsr.rsvisible
 msgid "Visible"
 msgstr ""

components/tvplanit/languages/vpsr.fr.po

@@ -262,6 +262,10 @@ msgstr "Supprimer la tache de votre liste?"
 msgid "Add contact..."
 msgstr "Ajouter un contact..."
 
+#: vpsr.rscontactpopupaddvcards
+msgid "Add contact from vCard(s)..."
+msgstr ""
+
 #: vpsr.rscontactpopupdelete
 msgid "Delete contact..."
 msgstr "Supprimer un contact..."
@@ -583,6 +587,10 @@ msgstr ""
 msgid "Load file..."
 msgstr ""
 
+#: vpsr.rsloadvcardstitle
+msgid "Load vCard(s)"
+msgstr ""
+
 #: vpsr.rslocation
 msgid "Location"
 msgstr ""
@@ -1121,7 +1129,9 @@ msgid "Error: Unable to update "
 msgstr "Erreur: Modification à echoué"
 
 #: vpsr.rsstartendtimeerror
-msgid "Incorrect order of start and end times. Do you want to flip them?"
+#, fuzzy
+#| msgid "Incorrect order of start and end times. Do you want to flip them?"
+msgid "Incorrect order of start and end times. Do you want to exchange them?"
 msgstr "Ordre incorrect des heures de début et de fin. Voulez-vous les retourner?"
 
 #: vpsr.rsstarttimelbl
@@ -1261,6 +1271,10 @@ msgstr ""
 msgid "WORK"
 msgstr ""
 
+#: vpsr.rsvcardfilter
+msgid "vCard files (*.vcf)|*.vcf"
+msgstr ""
+
 #: vpsr.rsvisible
 msgid "Visible"
 msgstr ""
@@ -1525,6 +1539,7 @@ msgid "Invalid XML Character found"
 msgstr "Caractère XML non valide trouvé"
 
 #: vpsr.sinvalidxmlversion
+#, fuzzy,badformat
 msgid "XMLPartner does not support XML specification greater than %s"
 msgstr "XMLPartner ne supporte pas la spécification XML supérieure à"
 
@@ -1633,6 +1648,7 @@ msgid "End of input while looking for delimiter: "
 msgstr "Fin de l'entrée tout en recherchant delimiter:"
 
 #: vpsr.sunknownaxis
+#, fuzzy,badformat
 msgid "Unknown axis specifier: %s"
 msgstr "Spécificateur d'axe inconnu"
 

components/tvplanit/languages/vpsr.nl.po

@@ -256,6 +256,10 @@ msgstr "Deze taak uit de lijst wissen?"
 msgid "Add contact..."
 msgstr "Contact toevoegen..."
 
+#: vpsr.rscontactpopupaddvcards
+msgid "Add contact from vCard(s)..."
+msgstr ""
+
 #: vpsr.rscontactpopupdelete
 msgid "Delete contact..."
 msgstr "Contact wissen..."
@@ -577,6 +581,10 @@ msgstr "M"
 msgid "Load file..."
 msgstr ""
 
+#: vpsr.rsloadvcardstitle
+msgid "Load vCard(s)"
+msgstr ""
+
 #: vpsr.rslocation
 msgid "Location"
 msgstr ""
@@ -1115,7 +1123,9 @@ msgid "Error: Unable to update "
 msgstr "Fout: Updaten niet mogelijk "
 
 #: vpsr.rsstartendtimeerror
-msgid "Incorrect order of start and end times. Do you want to flip them?"
+#, fuzzy
+#| msgid "Incorrect order of start and end times. Do you want to flip them?"
+msgid "Incorrect order of start and end times. Do you want to exchange them?"
 msgstr "Incorrecte volgorde van start- en eindtijden. Wilt u ze verwisselen?"
 
 #: vpsr.rsstarttimelbl
@@ -1255,6 +1265,10 @@ msgstr ""
 msgid "WORK"
 msgstr ""
 
+#: vpsr.rsvcardfilter
+msgid "vCard files (*.vcf)|*.vcf"
+msgstr ""
+
 #: vpsr.rsvisible
 msgid "Visible"
 msgstr ""

components/tvplanit/languages/vpsr.po

@@ -246,6 +246,10 @@ msgstr ""
 msgid "Add contact..."
 msgstr ""
 
+#: vpsr.rscontactpopupaddvcards
+msgid "Add contact from vCard(s)..."
+msgstr ""
+
 #: vpsr.rscontactpopupdelete
 msgid "Delete contact..."
 msgstr ""
@@ -567,6 +571,10 @@ msgstr ""
 msgid "Load file..."
 msgstr ""
 
+#: vpsr.rsloadvcardstitle
+msgid "Load vCard(s)"
+msgstr ""
+
 #: vpsr.rslocation
 msgid "Location"
 msgstr ""
@@ -1105,7 +1113,7 @@ msgid "Error: Unable to update "
 msgstr ""
 
 #: vpsr.rsstartendtimeerror
-msgid "Incorrect order of start and end times. Do you want to flip them?"
+msgid "Incorrect order of start and end times. Do you want to exchange them?"
 msgstr ""
 
 #: vpsr.rsstarttimelbl
@@ -1245,6 +1253,10 @@ msgstr ""
 msgid "WORK"
 msgstr ""
 
+#: vpsr.rsvcardfilter
+msgid "vCard files (*.vcf)|*.vcf"
+msgstr ""
+
 #: vpsr.rsvisible
 msgid "Visible"
 msgstr ""

components/tvplanit/languages/vpsr.ru.po

@@ -256,6 +256,10 @@ msgstr "Удалить эту задачу из вашего списка?"
 msgid "Add contact..."
 msgstr "Добавить контакт..."
 
+#: vpsr.rscontactpopupaddvcards
+msgid "Add contact from vCard(s)..."
+msgstr ""
+
 #: vpsr.rscontactpopupdelete
 msgid "Delete contact..."
 msgstr "Удалить контакт..."
@@ -577,6 +581,10 @@ msgstr ""
 msgid "Load file..."
 msgstr "Загрузить файл..."
 
+#: vpsr.rsloadvcardstitle
+msgid "Load vCard(s)"
+msgstr ""
+
 #: vpsr.rslocation
 msgid "Location"
 msgstr ""
@@ -1115,7 +1123,7 @@ msgid "Error: Unable to update "
 msgstr "Ошибка обновления"
 
 #: vpsr.rsstartendtimeerror
-msgid "Incorrect order of start and end times. Do you want to flip them?"
+msgid "Incorrect order of start and end times. Do you want to exchange them?"
 msgstr ""
 
 #: vpsr.rsstarttimelbl
@@ -1255,6 +1263,10 @@ msgstr ""
 msgid "WORK"
 msgstr ""
 
+#: vpsr.rsvcardfilter
+msgid "vCard files (*.vcf)|*.vcf"
+msgstr ""
+
 #: vpsr.rsvisible
 msgid "Visible"
 msgstr ""

components/tvplanit/laz_visualplanit.lpk

@@ -32,7 +32,7 @@ Portions created by TurboPower Software Inc. are Copyright (C) 2002 TurboPower S
 
 Contributor(s): "/>
     <Version Major="1" Release="11"/>
-    <Files Count="71">
+    <Files Count="72">
       <Item1>
         <Filename Value="source\vpbase.pas"/>
         <UnitName Value="VpBase"/>
@@ -317,6 +317,10 @@ Contributor(s): "/>
         <Filename Value="source\vpjsonds.pas"/>
         <UnitName Value="VpJSONDs"/>
       </Item71>
+      <Item72>
+        <Filename Value="source\vpvcard.pas"/>
+        <UnitName Value="vpvcard"/>
+      </Item72>
     </Files>
     <i18n>
       <EnableI18N Value="True"/>

components/tvplanit/source/include/vpsr.inc

@@ -161,16 +161,19 @@ resourcestring
 
   {Contact Specific}
   RSContactPopupAdd         = 'Add contact...';
+  RSContactPopupAddVCards   = 'Add contact from vCard(s)...';
   RSContactPopupEdit        = 'Edit contact...';
   RSContactPopupDelete      = 'Delete contact...';
   RSConfirmDeleteContact    = 'Delete contact %s?';
+  RSLoadVCardsTitle         = 'Load vCard(s)';
+  RSVCardFilter             = 'vCard files (*.vcf)|*.vcf';
 
   {Event Specific}
   RSEvent                   = 'Event';
   RSFromSchedule            = 'from your schedule?';
   RSConfirmDeleteEvent      = 'Delete event from schedule?';
   RSStartEndTimeError       = 'Incorrect order of start and end times. ' +
-                              'Do you want to flip them?';
+                              'Do you want to exchange them?';
   RSCannotEditOverlayedEvent= 'Cannot edit this overlayed event.';
   RSNoOverlayedEvents       = 'none';
   RSOverlayedEvent          = 'overlayed';

components/tvplanit/source/vpbase.pas

@@ -103,8 +103,11 @@ type
   TVpHolidayEvent = procedure(Sender: TObject; ADate: TDateTime;
     var AHolidayName: String) of object;
 
+  { Visual planit Exceptions }
+  EVpException = class(Exception);
+
   { XML exceptions }
-  EXML = class(Exception);
+  EXML = class(EVpException);
 
   EVpStreamError = class(EXML)
   private

components/tvplanit/source/vpcontactgrid.pas

@@ -177,12 +177,12 @@ type
     procedure cgHookUp;
     procedure Paint; override;
     procedure Loaded; override;
-    procedure cgSpawnContactEditDialog(IsNewContact: Boolean);
-    procedure cgSetActiveContactByCoord(Pnt: TPoint);
-    function GetContactIndexByCoord(Pnt: TPoint): Integer;
     procedure cgScrollHorizontal(Rows: Integer);
+    procedure cgSetActiveContactByCoord(Pnt: TPoint);
+    procedure cgSpawnContactEditDialog(IsNewContact: Boolean);
     procedure CreateParams(var Params: TCreateParams); override;
     procedure CreateWnd; override;
+    function GetContactIndexByCoord(Pnt: TPoint): Integer;
     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
     procedure MouseEnter; override;
     procedure MouseLeave; override;
@@ -190,6 +190,7 @@ type
     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
     procedure PopupAddContact(Sender: TObject);
+    procedure PopupAddVCards(Sender: TObject);
     procedure PopupDeleteContact(Sender: TObject);
     procedure PopupEditContact(Sender: TObject);
     procedure EditContact;
@@ -291,7 +292,7 @@ implementation
 
 uses
   SysUtils, DateUtils, Dialogs,
-  VpContactEditDlg, VpContactGridPainter;
+  VpVCard, VpContactEditDlg, VpContactGridPainter;
 
 
 (*****************************************************************************)
@@ -1472,32 +1473,42 @@ var
 
 begin
   if RSContactPopupAdd <> '' then begin
-    NewItem := TMenuItem.Create (Self);
+    NewItem := TMenuItem.Create(Self);
     NewItem.Caption := RSContactPopupAdd;
     NewItem.OnClick := PopupAddContact;
     NewItem.Tag := 0;
-    FDefaultPopup.Items.Add (NewItem);
+    FDefaultPopup.Items.Add(NewItem);
+  end;
+
+  if RsContactPopupAddVCards <> '' then begin
+    NewItem := TMenuItem.Create(Self);
+    NewItem.Caption := RSContactPopupAddVCards;
+    NewItem.OnClick := PopupAddVCards;
+    NewItem.Tag := 0;
+    FDefaultPopup.Items.Add(NewItem);
   end;
 
   if RSContactPopupEdit <> '' then begin
-    NewItem := TMenuItem.Create (Self);
+    NewItem := TMenuItem.Create(Self);
     NewItem.Caption := RSContactPopupEdit;
     NewItem.OnClick := PopupEditContact;
     NewItem.Tag := 1;
-    FDefaultPopup.Items.Add (NewItem);
+    FDefaultPopup.Items.Add(NewItem);
   end;
 
   if RSContactPopupDelete <> '' then begin
-    NewItem := TMenuItem.Create (Self);
+    NewItem := TMenuItem.Create(Self);
     NewItem.Caption := RSContactPopupDelete;
     NewItem.OnClick := PopupDeleteContact;
     NewItem.Tag := 1;
-    FDefaultPopup.Items.Add (NewItem);
+    FDefaultPopup.Items.Add(NewItem);
   end;
 end;
 {=====}
 
-procedure TVpContactGrid.PopupAddContact (Sender : TObject);
+procedure TVpContactGrid.PopupAddContact(Sender: TObject);
+var
+  id: Integer;
 begin
   if ReadOnly then                                                     
     Exit;                                                              
@@ -1508,13 +1519,58 @@ begin
   if not Assigned (DataStore.Resource) then                            
     Exit;                                                              
   { we must want to create a new contact }
-  FActiveContact := DataStore.Resource.Contacts.AddContact (
+  id := DataStore.GetNextID(ContactsTableName);
-                        DataStore.GetNextID (ContactsTableName));
+  FActiveContact := DataStore.Resource.Contacts.AddContact(id);
   { Allow the user to fill in all the new information }
   cgSpawnContactEditDialog(True);
 end;
 {=====}
 
+procedure TVpContactGrid.PopupAddVCards(Sender: TObject);
+var
+  dlg: TOpenDialog;
+  vcards: TVpVCards;
+  i: Integer;
+  fn: String;
+  id: Integer;
+begin
+  if ReadOnly or (not CheckCreateResource) or
+     (not Assigned(Datastore)) or (not Assigned(Datastore.Resource))
+  then
+    exit;
+
+  dlg := TOpenDialog.Create(nil);
+  try
+    dlg.Title := RSLoadVCardsTitle;
+    dlg.Filter := RSVCardFilter;
+    dlg.FileName := '';
+    dlg.Options := dlg.Options + [ofAllowMultiSelect, ofFileMustExist];
+    if dlg.Execute then begin
+      Screen.Cursor := crHourGlass;
+      Application.ProcessMessages;
+      vcards := TVpVCards.Create;
+      try
+        for fn in dlg.Files do begin
+          vcards.LoadFromFile(fn);
+          for i := 0 to vcards.Count-1 do begin
+            id := DataStore.GetNextID (ContactsTableName);
+            FActiveContact := Datastore.Resource.Contacts.AddContact(id);
+            FActiveContact.LoadFromVCard(vcards[i]);
+            Datastore.PostContacts;
+            DataStore.NotifyDependents;
+          end;
+        end;
+        Invalidate;
+      finally
+        vcards.Free;
+        Screen.Cursor := crDefault;
+      end;
+    end;
+  finally
+    dlg.Free;
+  end;
+end;
+
 procedure TVpContactGrid.PopupDeleteContact (Sender : TObject);
 begin
   if ReadOnly then                                                     

components/tvplanit/source/vpdata.pas

@@ -41,7 +41,7 @@ uses
   {$ENDIF}
   SysUtils, Classes, Dialogs, Graphics,
   {$IFDEF VERSION6} Types, {$ENDIF}
-  VpSR;
+  VpSR, VpVCard;
 
 type
   TVpEventRec = packed record
@@ -610,6 +610,7 @@ type
     function ContainsWorkData: Boolean;
     function ContainsHomeData: Boolean;
     function FullName: string;
+    procedure LoadFromVCard(ACard: TVpVCard);
 
     property Loading: Boolean read FLoading write FLoading;
     property Changed: Boolean read FChanged write SetChanged;
@@ -1879,6 +1880,124 @@ begin
     Result := FFirstName + ' ' + FLastName;
 end;
 
+procedure TVpContact.LoadFromVCard(ACard: TVpVCard);
+const
+  NUM_PHONES = 5;
+var
+  s: String;
+  dt: TDateTime;
+  phoneIdx: Integer;
+  phones: array[1..NUM_PHONES] of ^String;
+  phonetypes: array[1..NUM_PHONES] of ^Integer;
+begin
+  phones[1] := @FPhone1;   phonetypes[1] := @FPhoneType1;
+  phones[2] := @FPhone2;   phonetypes[2] := @FPhoneType2;
+  phones[3] := @FPhone3;   phonetypes[3] := @FPhoneType3;
+  phones[4] := @FPhone4;   phonetypes[4] := @FPhoneType4;
+  phones[5] := @FPhone5;   phonetypes[5] := @FPhoneType5;
+
+  FLastName := ACard.LastName;
+  FFirstName := ACard.FirstName;
+  FTitle := ACard.Title;
+
+  FCompany := ACard.Company;
+  FAddress1 := ACard.WorkAddress;
+  FCity1 := ACard.WorkCity;
+  FZip1 := ACard.WorkZip;
+  FState1 := ACard.WorkState;
+  FCountry1 := ACard.WorkCountry;
+  FAddressType1 := ord(atWork);
+
+  FAddress2 := ACard.HomeAddress;
+  FCity2 := ACard.HomeCity;
+  FZip2 := ACard.HomeZip;
+  FState2 := ACard.HomeState;
+  FCountry2 := ACard.HomeCountry;
+  FAddressType2 := ord(atHome);
+
+  FEmail1 := ACard.WorkEMail;
+  FEMailType1 := ord(mtWork);
+  FEmail2 := ACard.HomeEMail;
+  FEMailType2 := ord(mtHome);
+
+  phoneIdx := 1;
+  s := ACard.Mobile;
+  if s <> '' then begin
+    phones[phoneidx]^ := s;
+    phonetypes[phoneidx]^ := ord(ptMobile);
+    inc(phoneidx);
+  end;
+  s := ACard.WorkPhone;
+  if s <> '' then begin
+    phones[phoneidx]^ := s;
+    phonetypes[phoneidx]^ := ord(ptWork);
+    inc(phoneidx);
+  end;
+  s := ACard.WorkFax;
+  if s <> '' then begin
+    phones[phoneidx]^ := s;
+    phonetypes[phoneidx]^ := ord(ptWorkFax);
+    inc(phoneidx);
+  end;
+  s := ACard.Pager;
+  if s <> '' then begin
+    phones[phoneidx]^ := s;
+    phonetypes[phoneidx]^ := ord(ptPager);
+    inc(phoneidx);
+  end;
+  s := ACard.CarPhone;
+  if (s <> '') and (phoneIdx <= NUM_PHONES) then begin
+    phones[phoneidx]^ := s;
+    phonetypes[phoneidx]^ := ord(ptCar);
+    inc(phoneidx);
+  end;
+  s := ACard.HomePhone;
+  if (s <> '') and (phoneIdx <= NUM_PHONES) then begin
+    phones[phoneidx]^ := s;
+    phonetypes[phoneidx]^ := ord(ptHome);
+    inc(phoneidx);
+  end;
+  s := ACard.HomeFax;
+  if (s <> '') and (phoneIdx <= NUM_PHONES) then begin
+    phones[phoneidx]^ := s;
+    phonetypes[phoneidx]^ := ord(ptHomeFax);
+    inc(phoneidx);
+  end;
+  s := ACard.ISDN;
+  if (s <> '') and (phoneIdx <= NUM_PHONES) then begin
+    phones[phoneidx]^ := s;
+    phonetypes[phoneidx]^ := ord(ptISDN);
+    inc(phoneidx);
+  end;
+
+  s := ACard.Value['BDAY', ''];
+  if s <> '' then begin
+    dt := VCardDate(s);
+    if dt > -1 then FBirthdate := dt;
+  end;
+
+  s := ACard.Value['ANNIVERSARY', ''];
+  if s <> '' then begin
+    dt := VCardDate(s);
+    if dt > -1 then FAnniversary := dt;
+  end;
+
+  FNotes := ACard.Value['NOTE', ''];
+
+  FPosition := ACard.Value['TITLE', ''];
+  s := ACard.Value['ROLE', ''];
+  if s <> '' then begin
+    if FPosition = '' then
+      FPosition := s
+    else
+      FPosition := FPosition + '; ' + s;
+  end;
+
+  FOwner.FOwner.ContactsDirty := true;
+  FChanged := true;
+end;
+
+
 procedure TVpContact.SetBirthDate(Value: TDateTIme);
 begin
   if Value <> FBirthdate then begin

components/tvplanit/source/vpmisc.pas

@@ -67,6 +67,8 @@ function DefaultEpoch : Integer;
 procedure GetRGB(Clr : TColor; var IR, IG, IB : Byte);
 function GetStartOfWeek(Date: TDateTime; StartOn: TVpDayType): TDateTime;
 
+function Split(const AStr: String; ADelimiter: Char): TStringArray;
+
 procedure StripString(var Str: string);
   { strips non-alphanumeric characters from the beginning and end of the string}
 
@@ -197,6 +199,25 @@ uses
  {$ENDIF}
   VpSR, VpBaseDS;
 
+function Split(const AStr: String; ADelimiter: Char): TStringArray;
+var
+  L: TStrings;
+  i: Integer;
+begin
+  L := TStringList.Create;
+  try
+    L.Delimiter := ADelimiter;
+    L.StrictDelimiter := true;
+    L.DelimitedText := AStr;
+    SetLength(Result, L.Count);
+    if L.Count > 0 then
+      for i:=0 to L.Count-1 do
+        Result[i] := L[i];
+  finally
+    L.Free;
+  end;
+end;
+
 procedure StripString(var Str: string);
 begin
   if Length(Str) < 1 then

components/tvplanit/source/vpvcard.pas

@@ -0,0 +1,601 @@
+{ Reads vCard contact files }
+
+unit VpVCard;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, contnrs;
+
+type
+  TVpVCardItem = class
+  private
+    FRaw: String;
+    FKey: String;
+    FTags: TStrings;
+    FValue: String;
+  protected
+    procedure Analyze(AVersion: String);
+    procedure GetParts(AText, AVersion: String;
+      out AKey: String; out ATags: TStringArray; out AValue: String);
+    function UnEscape(AValueText: String): String;
+    function UnquotePrintable(AValueText: String): String;
+  public
+    constructor Create(AText: String);
+    destructor Destroy; override;
+    property Key: String read FKey;
+    property Tags: TStrings read FTags;
+    property Value: String read FValue;
+  end;
+
+  TVpVCard = class
+  private
+    FItems: TObjectList;
+    FVersion: String;
+
+    FFirstName: String;
+    FLastName: String;
+    FTitle: String;
+
+    FCompany: String;
+    FWorkAddress: String;
+    FWorkCity: String;
+    FWorkZip: String;
+    FWorkState: String;
+    FWorkCountry: String;
+    FWorkEMail: String;
+    FWorkPhone: String;
+    FWorkFax: String;
+
+    FHomeAddress: String;
+    FHomeCity: String;
+    FHomeZip: String;
+    FHomeState: String;
+    FHomeCountry: String;
+    FHomeEMail: String;
+    FHomePhone: String;
+    FHomeFax: String;
+
+    FMobile: String;
+    FCarPhone: String;
+    FISDN: String;
+    FPager: String;
+
+    function GetValue(const AKey, ATags: String): String;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure Add(const AText: String);
+    procedure Analyze;
+    function FindItem(AKey, ATags: String): TVpVCardItem;
+
+    property FirstName: String read FFirstName;
+    property LastName: String read FLastName;
+    property Title: String read FTitle;
+
+    property Company: String read FCompany;
+    property WorkAddress: String read FWorkAddress;
+    property WorkCity: String read FWorkCity;
+    property WorkZip: String read FWorkZip;
+    property WorkState: String read FWorkState;
+    property WorkCountry: String read FWorkCountry;
+    property WorkEMail: String read FWorkEMail;
+    property WorkPhone: String read FWorkPhone;
+    property WorkFax: String read FWorkFax;
+
+    property HomeAddress: String read FHomeAddress;
+    property HomeCity: String read FHomeCity;
+    property HomeZip: String read FHomeZip;
+    property HomeState: String read FHomeState;
+    property HomeCountry: String read FHomeCountry;
+    property HomeEMail: String read FHomeEMail;
+    property HomePhone: String read FHomePhone;
+    property HomeFax: String read FHomeFax;
+
+    property CarPhone: String read FCarPhone;
+    property Mobile: String read FMobile;
+    property ISDN: String read FISDN;
+    property Pager: String read FPager;
+
+    property Version: String read FVersion;
+    property Value[AKey: String; const ATags: String]: String read GetValue;
+  end;
+
+  TVpVCards = class
+  private
+    FCards: array of TVpVCard;
+    function GetCard(AIndex: Integer): TVpVCard;
+    function GetCount: Integer;
+  protected
+    procedure LoadFromStrings(const AStrings: TStrings);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure ClearCards;
+    procedure LoadFromFile(const AFileName: String);
+    procedure LoadFromStream(const AStream: TStream);
+    property Count: Integer read GetCount;
+    property Card[AIndex: Integer]: TVpVCard read GetCard; default;
+  end;
+
+procedure VCardAddress(AText: String;
+  out Address, ACity, AZip, AState, ACountry: String);
+
+function VCardDate(AText: String): TDate;
+
+procedure VCardName(AText: String; out ALastName, AFirstName, ATitle: String);
+
+implementation
+
+uses
+  StrUtils, DateUtils,
+  vpBase, vpMisc;
+
+const
+  ITEMS_DELIMITER = ';';
+
+{ Example:
+    ADR;TYPE=home:;;Heidestrasse 17;Koeln;;51147;Germany }
+procedure VCardAddress(AText: String;
+  out Address, ACity, AZip, AState, ACountry: String);
+var
+  strArr: TStringArray;
+begin
+  Address := '';
+  ACity := '';
+  AState := '';
+  ACountry := '';
+  strArr := Split(AText, ITEMS_DELIMITER);
+  { strArr[0] - post office box                                    ---> not used
+    strArr[1] - extended address (e.g., apartment or suite number) ---> not used
+    strArr[2] - street address
+    strArr[3] - locality (e.g., city)
+    strArr[4] - region (e.g., state or province)
+    strArr[5] - postal code
+    strArr[6] - country name }
+  if Length(strArr) > 2 then Address := strArr[2];
+  if Length(strArr) > 3 then ACity := strArr[3];
+  if Length(strArr) > 4 then AState := strArr[4];
+  if Length(strArr) > 5 then AZip := strArr[5];
+  if Length(strArr) > 6 then ACountry := strArr[6];
+end;
+
+function VCardDate(AText: String): TDate;
+var
+  fs: TFormatSettings;
+  value: String;
+  y, m, d: Integer;
+begin
+  if AText <> '' then begin
+    if TryStrToInt(copy(AText, 1, 4), y) and
+       TryStrToInt(copy(AText, 5, 2), m) and
+       TryStrToInt(copy(AText, 7, 2), d) then
+    begin
+      if TryEncodeDate(y, m, d, Result) then
+        exit;
+    end;
+    fs.ShortDateFormat := 'yyyy-mm-dd';
+    fs.LongDateFormat := fs.ShortDateFormat;
+    if TryStrToDate(AText, Result, fs) then
+      exit;
+  end;
+  Result := -1;
+end;
+
+{ Example:
+    N:Mustermann;Erika;;Dr.; }
+procedure VCardName(AText: String; out ALastName, AFirstName, ATitle: String);
+var
+  strArr: TStringArray;
+begin
+  ALastName := '';
+  AFirstName := '';
+  ATitle := '';
+  strArr := Split(AText, ITEMS_DELIMITER);
+  if Length(strArr) > 0 then ALastName := strArr[0];
+  if Length(strArr) > 1 then AFirstName := strArr[1];
+  if Length(strArr) > 3 then ATitle := strArr[3];
+end;
+
+
+{==============================================================================}
+{                              TVpVCardItem                                    }
+{==============================================================================}
+
+constructor TVpVCardItem.Create(AText: String);
+begin
+  inherited Create;
+  FRaw := AText;
+end;
+
+destructor TVpVCardItem.Destroy;
+begin
+  FTags.Free;
+  inherited;
+end;
+
+procedure TVpVCardItem.Analyze(AVersion: String);
+var
+  tagarray: TStringArray;
+  i: Integer;
+begin
+  GetParts(FRaw, AVersion, FKey, tagarray, FValue);
+  FTags := TStringList.Create;
+  for i:=0 to High(tagarray) do
+    FTags.Add(tagarray[i]);
+end;
+
+// Example:
+//   ADR;TYPE=WORK,POSTAL,PARCEL:;;One Microsoft Way;Redmond;WA;98052-6399;USA
+procedure TVpVCardItem.GetParts(AText, AVersion: String; out AKey: String;
+  out ATags: TStringArray; out AValue: String);
+var
+  p: Integer;
+  keypart, valuepart: String;
+  i: Integer;
+  QuotedPrintable: Boolean = false;
+  typeSeparator: Char;
+begin
+  // Split at ':' into key and value parts
+  p := pos(':', AText);
+  if p = 0 then
+    raise EVpException.CreateFmt('Illegal vcf structure in line "%s"', [AText]);
+  keypart := Uppercase(copy(AText, 1, p-1));
+  valuepart := copy(AText, p+1, MaxInt);
+
+  if AVersion = '2.1' then
+    typeseparator := ';'
+  else
+    typeseparator := ',';
+
+  // Process key part
+  p := pos(';', keypart);
+  if p = 0 then begin
+    AKey := keypart;
+    SetLength(ATags, 0);
+  end else begin
+    AKey := Copy(keypart, 1, p-1);
+    keypart := Copy(keypart, p+1, MaxInt);
+    p := pos('=', keypart);
+    if p > 0 then
+      keypart := copy(keypart, p+1, MaxInt);
+    ATags := Split(keypart, typeSeparator);
+    for i:=Low(ATags) to High(ATags) do
+      if ATags[i] = 'QUOTED-PRINTABLE' then begin
+        QuotedPrintable := true;
+        break;
+      end;
+  end;
+
+  // Process value part
+  if quotedPrintable then
+    AValue := UnquotePrintable(valuepart)
+  else
+    AValue := UnEscape(valuepart);
+end;
+
+function TVpVCardItem.UnEscape(AValueText: String): String;
+const
+  BUFSIZE = 100;
+var
+  p: PChar;
+  idx: Integer;
+
+  procedure AddChar(ch: Char);
+  begin
+    Result[idx] := ch;
+    inc(idx);
+    if idx > Length(Result) then SetLength(Result, Length(Result) + BUFSIZE);
+  end;
+
+begin
+  if AValueText = '' then begin
+    Result := '';
+    exit;
+  end;
+
+  SetLength(Result, Length(AValueText));
+  idx := 1;
+
+  p := @AValueText[1];
+  while p^ <> #0 do begin
+    if p^ = '\' then begin
+      inc(p);
+      if p^ = 'n' then begin
+        AddChar(LineEnding[1]);
+        if Length(LineEnding) > 1 then
+          AddChar(LineEnding[2]);
+      end else
+        AddChar(char(p^));
+    end else
+      AddChar(char(p^));
+    inc(p);
+  end;
+  SetLength(Result, idx-1);
+end;
+
+function TVpVCardItem.UnQuotePrintable(AValueText: String): String;
+const
+  BUFSIZE = 100;
+var
+  p: PChar;
+  idx: Integer;
+  code: String[2];
+  inUTF8: Boolean;
+  ch: Char;
+
+  procedure AddChar(ch: Char);
+  begin
+    Result[idx] := ch;
+    inc(idx);
+    if idx > Length(Result) then SetLength(Result, Length(Result) + BUFSIZE);
+  end;
+
+begin
+  if AValueText = '' then begin
+    Result := '';
+    exit;
+  end;
+
+  SetLength(Result, Length(AValueText));
+  idx := 1;
+  inUTF8 := false;
+
+  p := @AValueText[1];
+  while p^ <> #0 do begin
+    if p^ = '=' then begin
+      code := '';
+      inUTF8 := true;
+    end else
+    if inUTF8 then begin
+      if code = '' then
+        code := p^
+      else begin
+        code := code + p^;
+        ch := char(StrToInt('$'+code));
+        inUTF8 := false;
+        AddChar(ch);
+      end;
+    end else
+      AddChar(char(p^));
+    inc(p);
+  end;
+  SetLength(Result, idx-1);
+end;
+
+
+{==============================================================================}
+{                                TVpVCard                                      }
+{==============================================================================}
+
+constructor TVpVCard.Create;
+begin
+  inherited;
+  FItems := TObjectList.Create;
+end;
+
+destructor TVpVCard.Destroy;
+begin
+  FItems.Free;
+  inherited;
+end;
+
+procedure TVpVCard.Add(const AText: String);
+begin
+  if Pos('version', Lowercase(AText)) > 0 then
+    FVersion := Copy(AText, Pos(':', AText)+1, MaxInt);
+  FItems.Add(TVpVCardItem.Create(AText));
+end;
+
+procedure TVpVCard.Analyze;
+const
+  ITEM_SEPARATOR = '; ';
+var
+  i: Integer;
+  item: TVpVCardItem;
+  s: String;
+begin
+  for i := 0 to FItems.Count-1 do begin
+    item := TVpVCardItem(FItems[i]);
+    item.Analyze(FVersion);
+    case item.Key of
+      'FN':
+        VCardName(item.Value, FLastName, FFirstName, FTitle);
+      'ORG':
+        FCompany := item.Value;
+      'ADR':
+        if item.Tags.IndexOf('WORK') <> -1 then
+          VCardAddress(item.Value, FWorkAddress, FWorkCity, FWorkZip, FWorkState, FWorkCountry)
+        else if item.Tags.IndexOf('HOME') <> -1 then
+          VCardAddress(item.value, FHomeAddress, FHomeCity, FHomeZip, FHomeState, FHomeCountry)
+        else
+        if FCompany = '' then
+          VCardAddress(item.Value, FHomeAddress, FHomeCity, FHomeZip, FHomeState, FHomeCountry)
+        else
+          VCardAddress(item.Value, FWorkAddress, FWorkCity, FWorkZip, FWorkState, FWorkCountry);
+      'EMAIL':
+        if (FCompany = '') or (item.Tags.IndexOf('HOME') <> -1) then
+          FHomeEMail := IfThen(FHomeEMail = '', item.Value, FHomeEMail + ITEM_SEPARATOR + item.Value)
+        else
+          FWorkEMail := IfThen(FWorkEMail = '', item.Value, FWorkEMail + ITEM_SEPARATOR + item.Value);
+      'TEL':
+        if item.Tags.IndexOf('CELL') <> -1 then
+          FMobile := item.Value
+        else
+        if item.Tags.IndexOf('PAGER') <> -1 then
+          FPager := item.Value
+        else
+        if item.Tags.IndexOf('FAX') <> -1 then begin
+          if (FCompany = '') or (item.Tags.IndexOf('HOME') <> -1) then
+            FHomeFax := item.Value
+          else
+            FWorkFax := item.Value;
+        end else
+        if item.Tags.IndexOf('CAR') <> -1 then
+          FCarPhone := item.Value
+        else
+        if item.Tags.IndexOf('ISDN') <> -1 then
+          FISDN := item.Value
+        else
+        if (FCompany = '') or (item.tags.IndexOf('HOME') <> -1) then
+          FHomePhone := IfThen(FHomePhone = '', item.Value, FHomePhone + ITEM_SEPARATOR + item.Value)
+        else
+          FWorkPhone := IfThen(FWorkPhone = '', item.Value, FWorkPhone + ITEM_SEPARATOR + item.Value);
+    end;
+  end;
+end;
+
+{ Finds the item with the specified key and tags. Several tags can be combined
+  by a semicolon. If a tag name begins with a '-' then it must NOT be present.
+  The conditions are and-ed, i.e. all conditions must be met for the item to
+  be accepted. }
+function TVpVCard.FindItem(AKey, ATags: String): TVpVCardItem;
+var
+  i: Integer;
+  item: TVpVCardItem;
+  tagArr: TStringArray;
+  tag, notTag: String;
+  ok: Boolean;
+begin
+  tagArr := Split(ATags, ';');
+
+  for i:=0 to FItems.Count-1 do begin
+    item := TVpVCardItem(FItems[i]);
+    if (AKey = item.Key) then
+    begin
+      ok := true;                  // No tags specified --> use first item found
+      if Length(tagArr) > 0 then begin
+        for tag in tagArr do begin
+          if tag[1] = '-' then
+            notTag := Copy(tag, 2, MaxInt);
+          if item.Tags.IndexOf(tag) = -1 then begin  // Tag not found --> reject
+            ok := false;
+            break;
+          end;
+          if item.Tags.Indexof(notTag) <> -1 then begin // "NOT" tag found --> reject
+            ok := false;
+            break;
+          end;
+        end;
+      end;
+      if ok then begin
+        Result := item;
+        exit;
+      end;
+    end;
+  end;
+  Result := nil;
+end;
+
+function TVpVCard.GetValue(const AKey, ATags: String): String;
+var
+  item: TVpVCardItem;
+begin
+  item := FindItem(AKey, ATags);
+  if item <> nil then Result := item.Value else Result := '';
+end;
+
+
+{==============================================================================}
+{                                TVpCards                                      }
+{==============================================================================}
+
+constructor TVpVCards.Create;
+begin
+  inherited;
+  SetLength(FCards, 0);
+end;
+
+destructor TVpVCards.Destroy;
+begin
+  ClearCards;
+  inherited;
+end;
+
+procedure TVpVCards.ClearCards;
+var
+  j: Integer;
+begin
+  for j := Count-1 downto 0 do
+    FCards[j].Free;
+  SetLength(FCards, 0);
+end;
+
+function TVpVCards.GetCard(AIndex: Integer): TVpVCard;
+begin
+  Result := FCards[AIndex];
+end;
+
+function TVpVCards.GetCount: Integer;
+begin
+  Result := Length(FCards);
+end;
+
+procedure TVpVCards.LoadFromFile(const AFilename: String);
+var
+  L: TStrings;
+begin
+  L := TStringList.Create;
+  try
+    L.LoadFromFile(AFileName);
+    LoadFromStrings(L);
+  finally
+    L.Free;
+  end;
+end;
+
+procedure TVpVCards.LoadFromStream(const AStream: TStream);
+var
+  L: TStrings;
+begin
+  L := TStringList.Create;
+  try
+    L.LoadFromStream(AStream);
+    LoadFromStrings(L);
+  finally
+    L.Free;
+  end;
+end;
+
+procedure TVpVCards.LoadFromStrings(const AStrings: TStrings);
+const
+  BLOCK_SIZE = 100;
+var
+  p: Integer;
+  itemName: String;
+  itemValue: String;
+  i, n: Integer;
+  s: String;
+begin
+  // Clear item list
+  ClearCards;
+  n := 0;
+  SetLength(FCards, BLOCK_SIZE);
+
+  for i:=0 to AStrings.Count-1 do begin
+    s := AStrings[i];
+    if s = '' then
+      continue;
+    p := pos(':', s);
+    if p = 0 then
+      continue;
+    itemName := Uppercase(copy(s, 1, p-1));
+    itemValue := Uppercase(copy(s, p+1, MaxInt));
+    if (itemName = 'BEGIN') and (itemValue = 'VCARD') then begin
+      FCards[n] := TVpVCard.Create;
+      inc(n);
+      if n mod BLOCK_SIZE = 0 then
+        SetLength(FCards, Length(FCards) + BLOCK_SIZE);
+    end else
+    if (itemName = 'END') and (itemValue = 'VCARD') then
+      FCards[n-1].Analyze
+    else
+      FCards[n-1].Add(s);
+  end;
+  SetLength(FCards, n);
+end;
+
+end.
+