lazarus-ccr/components/tvplanit/source/vpvcard.pas

{ Imports vCard contact files }

unit VpVCard;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, VpBaseDataFiles;

const
  ITEM_SEPARATOR = ';';

type
  TVpVCardItem = class(TVpFileItem)
  end;

  TVpVCard = class(TVpFileBlock)
  private
    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;

    FBirthDay: TDateTime;
    FAnniversary: TDateTime;
    FCategories: TStrings;
    FPickedCategory: Integer;
    
    FChecked: Boolean;

    function GetCategory(AIndex: Integer): String;
    function GetCategoryCount: Integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Analyze; override;
    function FindItem(AKey, ATags: String): TVpVCardItem;
    
    function GetEMail: String;
    function GetFullName: String;
    function GetHomeAddress: String;
    function GetPhone: String;
    function GetWorkAddress: String;

    procedure SaveToStrings(AList: TStrings);

    property FirstName: String read FFirstName write FFirstName;
    property LastName: String read FLastName write FLastName;
    property Title: String read FTitle write FTitle;

    property Company: String read FCompany write FCompany;
    property WorkAddress: String read FWorkAddress write FWorkAddress;
    property WorkCity: String read FWorkCity write FWorkCity;
    property WorkZip: String read FWorkZip write FWorkZip;
    property WorkState: String read FWorkState write FWorkState;
    property WorkCountry: String read FWorkCountry write FWorkCountry;
    property WorkEMail: String read FWorkEMail write FWorkEMail;
    property WorkPhone: String read FWorkPhone write FWorkPhone;
    property WorkFax: String read FWorkFax write FWorkFax;

    property HomeAddress: String read FHomeAddress write FHomeAddress;
    property HomeCity: String read FHomeCity write FHomeCity;
    property HomeZip: String read FHomeZip write FHomeZip;
    property HomeState: String read FHomeState write FHomeState;
    property HomeCountry: String read FHomeCountry write FHomeCountry;
    property HomeEMail: String read FHomeEMail write FHomeEMail;
    property HomePhone: String read FHomePhone write FHomePhone;
    property HomeFax: String read FHomeFax write FHomeFax;

    property CarPhone: String read FCarPhone write FCarPhone;
    property Mobile: String read FMobile write FMobile;
    property ISDN: String read FISDN write FISDN;
    property Pager: String read FPager write FPager;

    property Anniversary: TDateTime read FAnniversary write FAnniversary;
    property BirthDay: TDateTime read FBirthday write FBirthDay;
    property Category[AIndex: Integer]: string read GetCategory;
    property CategoryCount: Integer read GetCategoryCount;
    property Categories: TStrings read FCategories write FCategories;
    property PickedCategory: Integer read FPickedCategory write FPickedCategory;

    property Version: String read FVersion;
    property Checked: Boolean read FChecked write FChecked default true;     // Flag to skip import
  end;

  TVpVCards = class
  private
    FCards: array of TVpVCard;
    function GetCard(AIndex: Integer): TVpVCard;
    function GetCount: Integer;
  protected
    procedure LoadFromStrings(const AStrings: TStrings);
    procedure SaveToStrings(AList: TStrings);

  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(ACard: TVpVCard);
    procedure ClearCards;
    procedure LoadFromFile(const AFileName: String);
    procedure LoadFromStream(const AStream: TStream);
    procedure SaveToFile(const AFileName: String);
    procedure SaveToStream(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,
  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;
  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;


{==============================================================================}
{                                TVpVCard                                      }
{==============================================================================}

constructor TVpVCard.Create;
begin
  inherited Create(TVpVCardItem);
  FChecked := true;
  FCategories := TStringList.Create;
  FCategories.Delimiter := ',';   // VCard categories are separated by comma in vcf file.
  FCategories.StrictDelimiter := true;
end;

destructor TVpVCard.Destroy;
begin
  FCategories.Free;
  inherited;
end;

procedure TVpVCard.Analyze;
var
  i: Integer;
  item: TVpVCardItem;
  fn, ln, t: String;
  fullName: String;
  fs: TFormatSettings;
  dt: TDateTime;
begin
  inherited;

  for i := 0 to FItems.Count-1 do begin
    item := TVpVCardItem(FItems[i]);
    case item.Key of
      'VERSION':
        FVersion := item.Value;
      'FN':
        fullName := item.Value;
      'N':
        begin
          VCardName(item.Value, ln, fn, t);
          if FLastName = '' then FLastName := ln;
          if FFirstName = '' then FFirstName := fn;
          if FTitle = '' then FTitle := t;
        end;
      'ORG':
        begin
          FCompany := item.Value;
          if (FCompany <> '') and (FCompany[Length(FCompany)] = ';') then
            Delete(FCompany, Length(FCompany), 1);
        end;
      'ADR':
        if item.Attributes.IndexOf('WORK') <> -1 then
          VCardAddress(item.Value, FWorkAddress, FWorkCity, FWorkZip, FWorkState, FWorkCountry)
        else if item.Attributes.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 (item.Attributes.IndexOf('WORK') <> -1) then
          FWorkEMail := IfThen(FWorkEMail = '', item.Value, FWorkEMail + ITEM_SEPARATOR + ' ' + item.Value)
        else
        if (FCompany = '') or (item.Attributes.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.Attributes.IndexOf('CELL') <> -1 then
          FMobile := item.Value
        else
        if item.Attributes.IndexOf('PAGER') <> -1 then
          FPager := item.Value
        else
        if item.Attributes.IndexOf('FAX') <> -1 then begin
          if (FCompany = '') or (item.Attributes.IndexOf('HOME') <> -1) then
            FHomeFax := item.Value
          else
            FWorkFax := item.Value;
        end else
        if item.Attributes.IndexOf('CAR') <> -1 then
          FCarPhone := item.Value
        else
        if item.Attributes.IndexOf('ISDN') <> -1 then
          FISDN := item.Value
        else
        if item.Attributes.IndexOf('WORK') <> -1 then
          FWorkPhone := IfThen(FWorkPhone = '', item.Value, FWorkPhone + ITEM_SEPARATOR + ' ' + item.Value)
        else
        if (item.Attributes.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);
      'BDAY', 'ANNIVERSARY':
        begin
          fs := FormatSettings;
          fs.DateSeparator := '-';
          fs.ShortDateFormat := 'yyyy/mm/dd';
          if TryStrToDate(item.Value, dt, fs) then
          begin
            if (item.Key = 'BDAY') then
              FBirthday := dt
            else if (item.Key = 'ANNIVERSARY') then
              FAnniversary := dt;
          end;
        end;
      'CATEGORIES':
        FCategories.CommaText := item.Value;
    end;
  end;
  
  if (FFirstName = '') and (FLastName = '') then
  begin
    FLastName := fullName;
    FFirstName := '';
    FTitle := '';
  end;
end;

function TVpVCard.FindItem(AKey, ATags: String): TVpVCardItem;
begin
  Result := TVpVCardItem(inherited FindItem(AKey, ATags));
end;

function TVpVCard.GetCategory(AIndex: Integer): String;
begin
  Result := FCategories[AIndex];
end;

function TVpVCard.GetCategoryCount: Integer;
begin
  Result := FCategories.Count;
end;

function TVpVCard.GetEMail: String;
begin
  Result := '';
  if WorkEMail <> '' then Result := Format('%s; %s (work)', [Result, WorkEMail]);
  if HomeEMail <> '' then Result := Format('%s; %s (home)', [Result, HomeEMail]);
  if Result <> '' then
    Delete(Result, 1, 2);
end;

function TVpVCard.GetFullName: String;
begin
  Result := LastName;
  if FirstName <> '' then Result := FirstName + ' ' + Result;
  if Title <> '' then Result := Result + ', ' + Title;
end;

function TVpVCard.GetHomeAddress: String;
begin
  Result := '';
  if (HomeAddress = '') and (HomeZip = '') and (HomeCity = '') then
    exit;
  Result := HomeAddress + ', ' + HomeZip + ' ' + HomeCity;
  if HomeState <> '' then
    Result := Result + ', ' + HomeState;
  if HomeCountry <> '' then
    Result := Result + ', ' + HomeCountry;
end;

function TVpVCard.GetPhone: String; 
begin
  Result := '';
  if WorkPhone <> '' then Result := Format('%s; %s (work)', [Result, WorkPhone]);
  if HomePhone <> '' then Result := Format('%s; %s (home)', [Result, HomePhone]);
  if Mobile <> '' then Result := Format('%s; %s (mobile)', [Result, Mobile]);
  if Result <> '' then Delete(Result, 1, 2);
end;
  
function TVpVCard.GetWorkAddress: String;
begin
  Result := '';
  if (Company = '') and (WorkAddress = '') and (WorkZip = '') and (WorkCity = '') then
    exit;

  Result := Company + ', ' + WorkAddress + ', ' + WorkZip + ' ' + WorkCity;
  if WorkState <> '' then
    Result := Result + ', ' + WorkState;
  if WorkCountry <> '' then
    Result := Result + ', ' + WorkCountry;
end;

procedure TVpVCard.SaveToStrings(AList: TStrings);
begin
  AList.Add('BEGIN:VCARD');
  AList.Add('VERSION:3.0');

  // Name
  AList.Add('FN:' + GetFullName);
  AList.Add('N:' + LastName + ';' + FirstName + ';;;');

  // Addresses
  if (WorkAddress <> '') or (WorkCity <> '') or (WorkZip <> '') or
     (WorkState <> '') or (WorkCountry <> '')
  then
    AList.Add('ADR;TYPE=WORK:' + WorkAddress + ';' + WorkCity + ';' +
      WorkState +';' + WorkZip + ';' + WorkCountry);
  if (HomeAddress <> '') or (HomeCity <> '') or (HomeZip <> '') or
     (HomeState <> '') or (HomeCountry <> '')
  then
    AList.Add('ADR;TYPE=HOME:' + HomeAddress + ';' + HomeCity + ';' +
      HomeState +';' + HomeZip + ';' + HomeCountry);

  // Company
  if Company <> '' then
    AList.Add('ORG:' + Company);

  // Phone numbers
  if WorkPhone <> '' then
    AList.Add('TEL;TYPE=WORK:' + WorkPhone);
  if HomePhone <> '' then
    AList.Add('TEL;TYPE=HOME:' + HomePhone);
  if Mobile <> '' then
    AList.Add('TEL;TYPE=CELL:' + Mobile);
  if CarPhone <> '' then
    AList.Add('TEL;TYPE=CAR:' + CarPhone);
  if ISDN <> '' then
    AList.Add('TEL;TYPE=ISDN:' + ISDN);
  if Pager <> '' then
    AList.Add('TEL;TYPE=PAGER:' + Pager);

  // Fax
  if WorkFax <> '' then
    AList.Add('TEL;TYPE="fax,work":' + WorkFax);
  if HomeFax <> '' then
    AList.Add('TEL;TYPE="fax,home":' + HomeFax);

  // E-Mail
  if WorkEMail <> '' then
    AList.Add('EMAIL;TYPE=WORK:' + WorkEMail);
  if HomeEMail <> '' then
    AList.Add('EMAIL;TYPE=HOME:' + HomeEMail);

  // Categories
  if Categories.Count > 0 then
    AList.Add('CATEGORIES:' + Categories.CommaText);

  AList.Add('END:VCARD');
end;


{==============================================================================}
{                                TVpCards                                      }
{==============================================================================}

constructor TVpVCards.Create;
begin
  inherited;
  SetLength(FCards, 0);
end;

destructor TVpVCards.Destroy;
begin
  ClearCards;
  inherited;
end;

procedure TVpVCards.Add(ACard: TVpVCard);
var
  n: Integer;
begin
  n := Length(FCards);
  SetLength(FCards, n+1);
  FCards[n] := ACard;
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;

procedure TVpVCards.SaveToFile(const AFileName: String);
var
  L: TStrings;
begin
  L := TStringList.Create;
  try
    SaveToStrings(L);
    L.SaveToFile(AFileName);
  finally
    L.Free;
  end;
end;

procedure TVpVCards.SaveToStream(const AStream: TStream);
var
  L: TStrings;
begin
  L := TStringList.Create;
  try
    SaveToStrings(L);
    L.SaveToStream(AStream);
  finally
    L.Free;
  end;
end;

procedure TVpVCards.SaveToStrings(AList: TStrings);
var
  i: Integer;
begin
  AList.Clear;
  for i := 0 to Count-1 do
    FCards[i].SaveToStrings(AList);
end;

end.