From 820288c8ecc43d348968770a2757e78860a16fd1 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Fri, 8 Jun 2018 20:03:23 +0000 Subject: [PATCH] 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 | 17 +- components/tvplanit/languages/vpsr.fi.po | 14 +- components/tvplanit/languages/vpsr.fr.po | 18 +- components/tvplanit/languages/vpsr.nl.po | 16 +- components/tvplanit/languages/vpsr.po | 14 +- components/tvplanit/languages/vpsr.ru.po | 14 +- components/tvplanit/laz_visualplanit.lpk | 6 +- components/tvplanit/source/include/vpsr.inc | 5 +- components/tvplanit/source/vpbase.pas | 5 +- components/tvplanit/source/vpcontactgrid.pas | 82 ++- components/tvplanit/source/vpdata.pas | 121 +++- components/tvplanit/source/vpmisc.pas | 21 + components/tvplanit/source/vpvcard.pas | 601 +++++++++++++++++++ 13 files changed, 911 insertions(+), 23 deletions(-) create mode 100644 components/tvplanit/source/vpvcard.pas diff --git a/components/tvplanit/languages/vpsr.de.po b/components/tvplanit/languages/vpsr.de.po index 50bdab581..ef7b39a52 100644 --- a/components/tvplanit/languages/vpsr.de.po +++ b/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." + diff --git a/components/tvplanit/languages/vpsr.fi.po b/components/tvplanit/languages/vpsr.fi.po index 1e241808a..a1a3d13e2 100644 --- a/components/tvplanit/languages/vpsr.fi.po +++ b/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 "" diff --git a/components/tvplanit/languages/vpsr.fr.po b/components/tvplanit/languages/vpsr.fr.po index d41704a76..0a55f8526 100644 --- a/components/tvplanit/languages/vpsr.fr.po +++ b/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" diff --git a/components/tvplanit/languages/vpsr.nl.po b/components/tvplanit/languages/vpsr.nl.po index 07e67106f..5d778aa9f 100644 --- a/components/tvplanit/languages/vpsr.nl.po +++ b/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 "" diff --git a/components/tvplanit/languages/vpsr.po b/components/tvplanit/languages/vpsr.po index 2f801c1b7..0fa41917d 100644 --- a/components/tvplanit/languages/vpsr.po +++ b/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 "" diff --git a/components/tvplanit/languages/vpsr.ru.po b/components/tvplanit/languages/vpsr.ru.po index 5d4b53e7a..7c43c2cc5 100644 --- a/components/tvplanit/languages/vpsr.ru.po +++ b/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 "" diff --git a/components/tvplanit/laz_visualplanit.lpk b/components/tvplanit/laz_visualplanit.lpk index bd5073121..cbd706bcf 100644 --- a/components/tvplanit/laz_visualplanit.lpk +++ b/components/tvplanit/laz_visualplanit.lpk @@ -32,7 +32,7 @@ Portions created by TurboPower Software Inc. are Copyright (C) 2002 TurboPower S Contributor(s): "/> - + @@ -317,6 +317,10 @@ Contributor(s): "/> + + + + diff --git a/components/tvplanit/source/include/vpsr.inc b/components/tvplanit/source/include/vpsr.inc index 548012d49..ccc00a17d 100644 --- a/components/tvplanit/source/include/vpsr.inc +++ b/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'; diff --git a/components/tvplanit/source/vpbase.pas b/components/tvplanit/source/vpbase.pas index cc9a4a3fe..4cb16a4e2 100644 --- a/components/tvplanit/source/vpbase.pas +++ b/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 diff --git a/components/tvplanit/source/vpcontactgrid.pas b/components/tvplanit/source/vpcontactgrid.pas index ca8e80ab8..16ce7c16c 100644 --- a/components/tvplanit/source/vpcontactgrid.pas +++ b/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 ( - DataStore.GetNextID (ContactsTableName)); + id := 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 diff --git a/components/tvplanit/source/vpdata.pas b/components/tvplanit/source/vpdata.pas index ed20409c4..3690bd8b8 100644 --- a/components/tvplanit/source/vpdata.pas +++ b/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 diff --git a/components/tvplanit/source/vpmisc.pas b/components/tvplanit/source/vpmisc.pas index 165258aab..89808dd3a 100644 --- a/components/tvplanit/source/vpmisc.pas +++ b/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 diff --git a/components/tvplanit/source/vpvcard.pas b/components/tvplanit/source/vpvcard.pas new file mode 100644 index 000000000..29d4264bb --- /dev/null +++ b/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. +