pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

tvplanit: Import contacts from vCards (*.vcf)

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6475 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-06-08 20:03:23 +00:00
parent 5bba58fa30
commit 820288c8ec
13 changed files with 911 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
components/tvplanit/languages/vpsr.de.po
View File

@ -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."

14
components/tvplanit/languages/vpsr.fi.po
View File

@ -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 ""

18
components/tvplanit/languages/vpsr.fr.po
View File

@ -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"

16
components/tvplanit/languages/vpsr.nl.po
View File

@ -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 ""

14
components/tvplanit/languages/vpsr.po
View File

@ -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 ""

14
components/tvplanit/languages/vpsr.ru.po
View File

@ -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 ""

6
components/tvplanit/laz_visualplanit.lpk
View File

@ -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"/>

5
components/tvplanit/source/include/vpsr.inc
View File

@ -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';

5
components/tvplanit/source/vpbase.pas
View File

@ -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

82
components/tvplanit/source/vpcontactgrid.pas
View File

@ -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

121
components/tvplanit/source/vpdata.pas
View File

@ -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

21
components/tvplanit/source/vpmisc.pas
View File

@ -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

601
components/tvplanit/source/vpvcard.pas Normal file
View File

@ -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.