units/indy/IdVCard.pas

   1 // 29-nov-2002
   2 unit IdVCard;
   3
   4 interface
   5
   6 uses KOL { ,
   7   Classes } ,
   8   IdBaseComponent, IdGlobal, KOLClasses;
   9
  10 type
  11   TIdVCardEmbeddedObject = object(TObj)
  12   protected
  13     FObjectType: string;
  14     FObjectURL: string;
  15     FBase64Encoded: Boolean;
  16     FEmbeddedData: PStrList;
  17     procedure SetEmbeddedData(const Value: PStrList);
  18   public
  19      { constructor Create;
  20      } destructor Destroy;
  21    virtual;  { published }
  22     property ObjectType: string read FObjectType write FObjectType;
  23     property ObjectURL: string read FObjectURL write FObjectURL;
  24     property Base64Encoded: Boolean read FBase64Encoded write FBase64Encoded;
  25     property EmbeddedData: PStrList read FEmbeddedData write SetEmbeddedData;
  26   end;
  27 PIdVCardEmbeddedObject=^TIdVCardEmbeddedObject;
  28 function NewIdVCardEmbeddedObject:PIdVCardEmbeddedObject;
  29 type
  30
  31   TIdVCardBusinessInfo = object(TObj)
  32   protected
  33     FTitle: string;
  34     FRole: string;
  35     FOrganization: string;
  36     FDivisions: PStrList;
  37     procedure SetDivisions(Value: PStrList);
  38   public
  39      { constructor Create;
  40      } destructor Destroy;
  41    virtual;  { published }
  42     property Organization: string read FOrganization write FOrganization;
  43     property Divisions: PStrList read FDivisions write SetDivisions;
  44     property Title: string read FTitle write FTitle;
  45     property Role: string read FRole write FRole;
  46   end;
  47 PIdVCardBusinessInfo=^TIdVCardBusinessInfo;
  48 function NewIdVCardBusinessInfo:PIdVCardBusinessInfo;
  49 type
  50
  51   TIdVCardGeog = object(TObj)
  52   protected
  53     FLatitude: Real;
  54     FLongitude: Real;
  55     FTimeZoneStr: string;
  56    { published }
  57     property Latitude: Real read FLatitude write FLatitude;
  58     property Longitude: Real read FLongitude write FLongitude;
  59     property TimeZoneStr: string read FTimeZoneStr write FTimeZoneStr;
  60   end;
  61 PIdVCardGeog=^TIdVCardGeog;
  62 function NewIdVCardGeog:PIdVCardGeog;
  63 type
  64
  65   TIdPhoneAttributes = set of
  66     (tpaHome, tpaVoiceMessaging, tpaWork, tpaPreferred, tpaVoice, tpaFax,
  67     paCellular, tpaVideo, tpaBBS, tpaModem, tpaCar, tpaISDN, tpaPCS, tpaPager);
  68
  69   TIdCardPhoneNumber = object(TCollectionItem)
  70   protected
  71     FPhoneAttributes: TIdPhoneAttributes;
  72     FNumber: string;
  73   public
  74     procedure Assign(Source: PObj);// override;
  75    { published }
  76     property PhoneAttributes: TIdPhoneAttributes
  77     read FPhoneAttributes write FPhoneAttributes;
  78     property Number: string read FNumber write FNumber;
  79   end;
  80 PIdCardPhoneNumber=^TIdCardPhoneNumber;
  81 function NewIdCardPhoneNumber:PIdCardPhoneNumber;
  82  type
  83
  84   TIdVCardTelephones = object(TOwnedCollection)
  85   protected
  86     function GetItem(Index: Integer): TIdCardPhoneNumber;
  87     procedure SetItem(Index: Integer; const Value: TIdCardPhoneNumber);
  88   public
  89      { constructor Create(AOwner: TPersistent);  }// reintroduce;
  90     function Add: TIdCardPhoneNumber;
  91     property Items[Index: Integer]: TIdCardPhoneNumber read GetItem write
  92     SetItem; default;
  93   end;
  94 PIdVCardTelephones=^TIdVCardTelephones;
  95 function NewIdVCardTelephones(AOwner: PObj):PIdVCardTelephones;
  96 type
  97
  98   TIdCardAddressAttributes = set of (tatHome, tatDomestic, tatInternational,
  99     tatPostal,
 100     tatParcel, tatWork, tatPreferred);
 101   TIdCardAddressItem = object(TCollectionItem)
 102   protected
 103     FAddressAttributes: TIdCardAddressAttributes;
 104     FPOBox: string;
 105     FExtendedAddress: string;
 106     FStreetAddress: string;
 107     FLocality: string;
 108     FRegion: string;
 109     FPostalCode: string;
 110     FNation: string;
 111   public
 112     procedure Assign(Source: PObj); //override;
 113    { published }
 114     property AddressAttributes: TIdCardAddressAttributes read
 115     FAddressAttributes write FAddressAttributes;
 116     property POBox: string read FPOBox write FPOBox;
 117     property ExtendedAddress: string read FExtendedAddress write
 118       FExtendedAddress;
 119     property StreetAddress: string read FStreetAddress write FStreetAddress;
 120     property Locality: string read FLocality write FLocality;
 121     property Region: string read FRegion write FRegion;
 122     property PostalCode: string read FPostalCode write FPostalCode;
 123     property Nation: string read FNation write FNation;
 124   end;
 125 PIdCardAddressItem=^TIdCardAddressItem;
 126 function NewIdCardAddressItem:PIdCardAddressItem;
 127 type
 128
 129   TIdVCardAddresses = object(TOwnedCollection)
 130   protected
 131     function GetItem(Index: Integer): TIdCardAddressItem;
 132     procedure SetItem(Index: Integer; const Value: TIdCardAddressItem);
 133   public
 134      { constructor Create(AOwner: TPersistent);  }// reintroduce;
 135     function Add: TIdCardAddressItem;
 136     property Items[Index: Integer]: TIdCardAddressItem read GetItem write
 137     SetItem; default;
 138   end;
 139 PIdVCardAddresses=^TIdVCardAddresses;
 140 function NewIdVCardAddresses(AOwner: PObj):PIdVCardAddresses;
 141  type
 142
 143   TIdVCardMailingLabelItem = object(TCollectionItem)
 144   private
 145     FAddressAttributes: TIdCardAddressAttributes;
 146     FMailingLabel: PStrList;
 147     procedure SetMailingLabel(Value: PStrList);
 148   public
 149      { constructor Create(Collection: TCollection); override;
 150      } destructor Destroy;
 151      virtual; procedure Assign(Source: PObj);// override;
 152    { published }
 153     property AddressAttributes: TIdCardAddressAttributes read
 154     FAddressAttributes write FAddressAttributes;
 155     property MailingLabel: PStrList read FMailingLabel write SetMailingLabel;
 156   end;
 157 PIdVCardMailingLabelItem=^TIdVCardMailingLabelItem;
 158 function NewIdVCardMailingLabelItem(Collection: PCollection):PIdVCardMailingLabelItem;
 159 type
 160
 161   TIdVCardMailingLabels = object(TOwnedCollection)
 162   protected
 163     function GetItem(Index: Integer): TIdVCardMailingLabelItem;
 164     procedure SetItem(Index: Integer; const Value: TIdVCardMailingLabelItem);
 165   public
 166      { constructor Create(AOwner: TPersistent);  } //reintroduce;
 167     function Add: TIdVCardMailingLabelItem;
 168     property Items[Index: Integer]: TIdVCardMailingLabelItem read GetItem write
 169       SetItem; default;
 170   end;
 171 PIdVCardMailingLabels=^TIdVCardMailingLabels;
 172 function NewIdVCardMailingLabels(AOwner: PObj):PIdVCardMailingLabels;
 173 type
 174   TIdVCardEMailType = (ematAOL,
 175     ematAppleLink,
 176     ematATT,
 177     ematCIS,
 178     emateWorld,
 179     ematInternet,
 180     ematIBMMail,
 181     ematMCIMail,
 182     ematPowerShare,
 183     ematProdigy,
 184     ematTelex,
 185     ematX400);
 186
 187   TIdVCardEMailItem = object(TCollectionItem)
 188   protected
 189     FEMailType: TIdVCardEMailType;
 190     FPreferred: Boolean;
 191     FAddress: string;
 192   public
 193      { constructor Create(Collection: TCollection); override;
 194      } procedure Assign(Source: PObj);// override;
 195    { published }
 196     property EMailType: TIdVCardEMailType read FEMailType write FEMailType;
 197     property Preferred: Boolean read FPreferred write FPreferred;
 198     property Address: string read FAddress write FAddress;
 199   end;
 200 PIdVCardEMailItem=^TIdVCardEMailItem;
 201 function NewIdVCardEMailItem(Collection: PCollection):PIdVCardEMailItem;
 202 type
 203
 204   TIdVCardEMailAddresses = object(TOwnedCollection)
 205   protected
 206     function GetItem(Index: Integer): TIdVCardEMailItem;
 207     procedure SetItem(Index: Integer; const Value: TIdVCardEMailItem);
 208   public
 209      { constructor Create(AOwner: TPersistent);  }// reintroduce;
 210     function Add: TIdVCardEMailItem;
 211     property Items[Index: Integer]: TIdVCardEMailItem read GetItem write
 212       SetItem; default;
 213   end;
 214 PIdVCardEMailAddresses=^TIdVCardEMailAddresses;
 215 function NewIdVCardEMailAddresses(AOwner: PObj):PIdVCardEMailAddresses; type
 216
 217   TIdVCardName = object(TObj)
 218   protected
 219     FFirstName: string;
 220     FSurName: string;
 221     FOtherNames: PStrList;
 222     FPrefix: string;
 223     FSuffix: string;
 224     FFormattedName: string;
 225     FSortName: string;
 226     FNickNames: PStrList;
 227     procedure SetOtherNames(Value: PStrList);
 228     procedure SetNickNames(Value: PStrList);
 229   public
 230      { constructor Create;
 231      } destructor Destroy;
 232    virtual;  { published }
 233     property FirstName: string read FFirstName write FFirstName;
 234     property SurName: string read FSurName write FSurName;
 235     property OtherNames: PStrList read FOtherNames write SetOtherNames;
 236     property FormattedName: string read FFormattedName write FFormattedName;
 237     property Prefix: string read FPrefix write FPrefix;
 238     property Suffix: string read FSuffix write FSuffix;
 239     property SortName: string read FSortName write FSortName;
 240     property NickNames: PStrList read FNickNames write SetNickNames;
 241   end;
 242 PIdVCardName=^TIdVCardName;
 243 function NewIdVCardName:PIdVCardName;
 244 type
 245
 246   TIdVCard = object(TIdBaseComponent)
 247   private
 248   protected
 249     FComments: PStrList;
 250     FCatagories: PStrList;
 251     FBusinessInfo: TIdVCardBusinessInfo;
 252     FGeography: TIdVCardGeog;
 253     FFullName: TIdVCardName;
 254     FRawForm: PStrList;
 255     FURLs: PStrList;
 256     FEMailProgram: string;
 257     FEMailAddresses: TIdVCardEMailAddresses;
 258     FAddresses: TIdVCardAddresses;
 259     FMailingLabels: TIdVCardMailingLabels;
 260     FTelephones: TIdVCardTelephones;
 261     FVCardVersion: Real;
 262     FProductID: string;
 263     FUniqueID: string;
 264     FClassification: string;
 265     FLastRevised: TDateTime;
 266     FBirthDay: TDateTime;
 267     FPhoto: TIdVCardEmbeddedObject;
 268     FLogo: TIdVCardEmbeddedObject;
 269     FSound: TIdVCardEmbeddedObject;
 270     FKey: TIdVCardEmbeddedObject;
 271     procedure SetComments(Value: PStrList);
 272     procedure SetCatagories(Value: PStrList);
 273     procedure SetURLs(Value: PStrList);
 274     procedure SetVariablesAfterRead;
 275   public
 276      { constructor Create(AOwner: TComponent); override;
 277      } destructor Destroy;
 278      virtual; procedure ReadFromPStrList(s: PStrList);
 279     property RawForm: PStrList read FRawForm;
 280    { published }
 281     property VCardVersion: Real read FVCardVersion;
 282     property URLs: PStrList read FURLs write SetURLs;
 283     property ProductID: string read FProductID write FProductID;
 284     property UniqueID: string read FUniqueID write FUniqueID;
 285     property Classification: string read FClassification write FClassification;
 286     property BirthDay: TDateTime read FBirthDay write FBirthDay;
 287     property FullName: TIdVCardName read FFullName write FFullName;
 288     property EMailProgram: string read FEMailProgram write FEMailProgram;
 289     property EMailAddresses: TIdVCardEMailAddresses read FEMailAddresses;
 290     property Telephones: TIdVCardTelephones read FTelephones;
 291     property BusinessInfo: TIdVCardBusinessInfo read FBusinessInfo;
 292     property Catagories: PStrList read FCatagories write SetCatagories;
 293     property Addresses: TIdVCardAddresses read FAddresses;
 294     property MailingLabels: TIdVCardMailingLabels read FMailingLabels;
 295     property Comments: PStrList read FComments write SetComments;
 296     property Photo: TIdVCardEmbeddedObject read FPhoto;
 297     property Logo: TIdVCardEmbeddedObject read FLogo;
 298     property Sound: TIdVCardEmbeddedObject read FSound;
 299     property Key: TIdVCardEmbeddedObject read FKey;
 300   end;
 301 PIdVCard=^TIdVCard;
 302 function NewIdVCard(AOwner: PControl):PIdVCard;
 303
 304 implementation
 305
 306 uses
 307   IdCoderText,
 308   SysUtils;
 309
 310 const
 311   VCardProperties: array[1..28] of string = (
 312     'FN', 'N', 'NICKNAME', 'PHOTO',
 313     'BDAY', 'ADR', 'LABEL', 'TEL',
 314     'EMAIL', 'MAILER', 'TZ', 'GEO',
 315     'TITLE', 'ROLE', 'LOGO', 'AGENT',
 316     'ORG', 'CATEGORIES', 'NOTE', 'PRODID',
 317     'REV', 'SORT-STRING', 'SOUND', 'URL',
 318     'UID', 'VERSION', 'CLASS', 'KEY');
 319 { These constants are for testing the VCard for E-Mail types.
 320   Don't alter these }
 321 const
 322   EMailTypePropertyParameter: array[1..12] of string =
 323   ('AOL',
 324     'APPLELINK',
 325     'ATTMAIL',
 326     'CIS',
 327     'EWORLD',
 328     'INTERNET',
 329     'IBMMAIL',
 330     'MCIMAIL',
 331     'POWERSHARE',
 332     'PRODIGY',
 333     'TLX',
 334     'X400');
 335
 336 procedure AddValueToStrings(strs: PStrList; Value: string);
 337 begin
 338   if (Length(Value) <> 0) then
 339   begin
 340     strs.Add(Value);
 341   end;
 342 end;
 343
 344 procedure ParseDelinatorToPStrList(strs: PStrList; str: string;
 345   deliniator: Char = ',');
 346 begin
 347   while (str <> '') do
 348   begin
 349     AddValueToStrings(strs, Fetch(str, deliniator));
 350   end;
 351 end;
 352
 353 function ParseDateTimeStamp(DateString: string): TDateTime;
 354 var
 355   Year, Day, Month: Integer;
 356   Hour, Minute, Second: Integer;
 357 begin
 358   Year := StrToInt(Copy(DateString, 1, 4));
 359   Month := StrToInt(Copy(DateString, 5, 2));
 360   Day := StrToInt(Copy(DateString, 7, 2));
 361   if (Length(DateString) > 14) then
 362   begin
 363     Hour := StrToInt(Copy(DateString, 10, 2));
 364     Minute := StrToInt(Copy(DateString, 12, 2));
 365     Second := StrToInt(Copy(DateString, 14, 2));
 366   end
 367   else
 368   begin
 369     Hour := 0;
 370     Minute := 0;
 371     Second := 0;
 372   end;
 373   Result := EncodeDate(Year, Month, Day) + EncodeTime(Hour, Minute, Second, 0);
 374 end;
 375
 376 function GetAttributesAndValue(data: string; var value: string): PStrList;
 377 var
 378   Buff, Buff2: string;
 379 begin
 380 //  Result := PStrList.Create;
 381 //  Result.Sorted := False;
 382   if Pos(':', Data) <> 0 then
 383   begin
 384     Buff := idGlobal.Fetch(Data, ':');
 385     StringReplace(Buff, ',', ';', [rfReplaceAll]);
 386     while (Buff <> '') do
 387     begin
 388       Buff2 := IdGlobal.Fetch(Buff, ';');
 389       if (Length(Buff2) > 0) then
 390       begin
 391         Result.Add(UpperCase(Buff2));
 392       end;
 393     end;
 394   end;
 395   Value := Data;
 396 end;
 397
 398 procedure ParseOrg(OrgObj: TIdVCardBusinessInfo; OrgStr: string);
 399 begin
 400   OrgObj.Organization := Fetch(OrgStr);
 401   ParseDelinatorToPStrList(OrgObj.Divisions, OrgStr, ';');
 402 end;
 403
 404 procedure ParseGeography(Geog: TIdVCardGeog; GeogStr: string);
 405 begin
 406   Geog.Latitude := StrToFloat(Fetch(GeogStr, ';'));
 407   Geog.Longitude := StrToFloat(Fetch(GeogStr, ';'));
 408 end;
 409
 410 procedure ParseTelephone(PhoneObj: TIdCardPhoneNumber; PhoneStr: string);
 411 var
 412   Value: string;
 413   idx: Integer;
 414   Attribs: PStrList;
 415
 416 const
 417   TelephoneTypePropertyParameter: array[0..13] of string =
 418   ('HOME', 'MSG', 'WORK', 'PREF', 'VOICE', 'FAX',
 419     'CELL', 'VIDEO', 'BBS', 'MODEM', 'CAR', 'ISDN',
 420     'PCS', 'PAGER');
 421 begin
 422   attribs := GetAttributesAndValue(PhoneStr, Value);
 423   try
 424     idx := 0;
 425     while idx < Attribs.Count do
 426     begin
 427 {      case idGlobal.PosInStrArray(attribs[idx], TelephoneTypePropertyParameter)
 428         of
 429         0: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaHome];
 430         1: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes +
 431           [tpaVoiceMessaging];
 432         2: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaWork];
 433         3: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes +
 434           [tpaPreferred];
 435         4: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaVoice];
 436         5: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaFax];
 437         6: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [paCellular];
 438         7: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaVideo];
 439         8: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaBBS];
 440         9: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaModem];
 441         10: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaCar];
 442         11: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaISDN];
 443         12: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaPCS];
 444         13: PhoneObj.PhoneAttributes := PhoneObj.PhoneAttributes + [tpaPager];
 445       end;}
 446       inc(idx);
 447     end;
 448     if (Attribs.Count = 0) then
 449     begin
 450       PhoneObj.PhoneAttributes := [tpaVoice];
 451     end;
 452     PhoneObj.Number := Value;
 453   finally
 454     FreeAndNil(attribs);
 455   end;
 456 end;
 457
 458 procedure ParseAddress(AddressObj: TIdCardAddressItem; AddressStr: string);
 459 var
 460   Value: string;
 461   Attribs: PStrList;
 462   idx: Integer;
 463 const
 464   AttribsArray: array[0..6] of string =
 465   ('HOME', 'DOM', 'INTL', 'POSTAL', 'PARCEL', 'WORK', 'PREF');
 466 begin
 467   Attribs := GetAttributesAndValue(AddressStr, Value);
 468   try
 469     idx := 0;
 470     while idx < Attribs.Count do
 471     begin
 472 {      case idGlobal.PosInStrArray(attribs[idx], AttribsArray) of
 473         0:
 474           AddressObj.AddressAttributes :=
 475             AddressObj.AddressAttributes + [tatHome];
 476         1:
 477           AddressObj.AddressAttributes :=
 478             AddressObj.AddressAttributes + [tatDomestic];
 479         2:
 480           AddressObj.AddressAttributes :=
 481             AddressObj.AddressAttributes + [tatInternational];
 482         3:
 483           AddressObj.AddressAttributes :=
 484             AddressObj.AddressAttributes + [tatPostal];
 485         4:
 486           AddressObj.AddressAttributes :=
 487             AddressObj.AddressAttributes + [tatParcel];
 488         5:
 489           AddressObj.AddressAttributes :=
 490             AddressObj.AddressAttributes + [tatWork];
 491         6:
 492           AddressObj.AddressAttributes :=
 493             AddressObj.AddressAttributes + [tatPreferred];
 494       end;}
 495       inc(idx);
 496     end;
 497     if (Attribs.Count = 0) then
 498     begin
 499       AddressObj.AddressAttributes := [tatInternational, tatPostal, tatParcel,
 500         tatWork];
 501     end;
 502     AddressObj.POBox := idGlobal.Fetch(Value, ';');
 503     AddressObj.ExtendedAddress := idGlobal.Fetch(Value, ';');
 504     AddressObj.StreetAddress := idGlobal.Fetch(Value, ';');
 505     AddressObj.Locality := idGlobal.Fetch(Value, ';');
 506     AddressObj.Region := idGlobal.Fetch(Value, ';');
 507     AddressObj.PostalCode := idGlobal.Fetch(Value, ';');
 508     AddressObj.Nation := idGlobal.Fetch(Value, ';');
 509   finally
 510     FreeAndNil(Attribs);
 511   end;
 512 end;
 513
 514 procedure ParseMailingLabel(LabelObj: TIdVCardMailingLabelItem; LabelStr:
 515   string);
 516 var
 517   Value: string;
 518   Attribs: PStrList;
 519   idx: Integer;
 520 const
 521   AttribsArray: array[0..6] of string =
 522   ('HOME', 'DOM', 'INTL', 'POSTAL', 'PARCEL', 'WORK', 'PREF');
 523 begin
 524   Attribs := GetAttributesAndValue(LabelStr, Value);
 525   try
 526     idx := 0;
 527     while idx < Attribs.Count do
 528     begin
 529 {      case idGlobal.PosInStrArray(attribs[idx], AttribsArray) of
 530         0:
 531           LabelObj.AddressAttributes :=
 532             LabelObj.AddressAttributes + [tatHome];
 533         1:
 534           LabelObj.AddressAttributes :=
 535             LabelObj.AddressAttributes + [tatDomestic];
 536         2:
 537           LabelObj.AddressAttributes :=
 538             LabelObj.AddressAttributes + [tatInternational];
 539         3:
 540           LabelObj.AddressAttributes :=
 541             LabelObj.AddressAttributes + [tatPostal];
 542         4:
 543           LabelObj.AddressAttributes :=
 544             LabelObj.AddressAttributes + [tatParcel];
 545         5:
 546           LabelObj.AddressAttributes :=
 547             LabelObj.AddressAttributes + [tatWork];
 548         6:
 549           LabelObj.AddressAttributes :=
 550             LabelObj.AddressAttributes + [tatPreferred];
 551       end;}
 552       inc(idx);
 553     end;
 554     if Attribs.Count = 0 then
 555     begin
 556       LabelObj.AddressAttributes := [tatInternational, tatPostal, tatParcel,
 557         tatWork];
 558     end;
 559     LabelObj.MailingLabel.Add(Value);
 560   finally
 561     FreeAndNil(Attribs);
 562   end;
 563 end;
 564
 565 procedure ParseName(NameObj: TIdVCardName; NameStr: string);
 566 var
 567   OtherNames: string;
 568
 569 begin
 570   NameObj.SurName := Fetch(NameStr, ';');
 571   NameObj.FirstName := Fetch(NameStr, ';');
 572   OtherNames := Fetch(NameStr, ';');
 573   NameObj.Prefix := Fetch(NameStr, ';');
 574   NameObj.Suffix := Fetch(NameStr, ';');
 575   OtherNames := StringReplace(OtherNames, ' ', ',', [rfReplaceAll]);
 576   ParseDelinatorToPStrList(NameObj.OtherNames, OtherNames);
 577 end;
 578
 579 procedure ParseEMailAddress(EMailObj: TIdVCardEMailItem; EMailStr: string);
 580 var
 581   Value: string;
 582   Attribs: PStrList;
 583   idx: Integer;
 584   ps: Integer;
 585 begin
 586   Attribs := GetAttributesAndValue(EMailStr, Value);
 587   try
 588     EMailObj.Address := Value;
 589     EMailObj.Preferred := (attribs.IndexOf('PREF') <> -1);
 590     idx := 0;
 591     ps := -1;
 592     while (idx < Attribs.Count) and (ps = -1) do
 593     begin
 594 {      ps := PosInStrArray(Attribs[idx], EMailTypePropertyParameter);
 595       case ps of
 596         0: EMailObj.EMailType := ematAOL;
 597         1: EMailObj.EMailType := ematAppleLink;
 598         2: EMailObj.EMailType := ematATT;
 599         3: EMailObj.EMailType := ematCIS;
 600         4: EMailObj.EMailType := emateWorld;
 601         5: EMailObj.EMailType := ematInternet;
 602         6: EMailObj.EMailType := ematIBMMail;
 603         7: EMailObj.EMailType := ematMCIMail;
 604         8: EMailObj.EMailType := ematPowerShare;
 605         9: EMailObj.EMailType := ematProdigy;
 606         10: EMailObj.EMailType := ematTelex;
 607         11: EMailObj.EMailType := ematX400;
 608       end;     }
 609       inc(idx);
 610     end;
 611   finally
 612     FreeAndNil(Attribs);
 613   end;
 614 end;
 615
 616 function NewIdVCard(AOwner: PControl):PIdVCard;
 617 //constructor TIdVCard.Create(AOwner: TComponent);
 618 begin
 619   New( Result, Create );
 620 with Result^ do
 621 begin
 622 {  inherited;
 623   FPhoto := TIdVCardEmbeddedObject.Create;
 624   FLogo := TIdVCardEmbeddedObject.Create;
 625   FSound := TIdVCardEmbeddedObject.Create;
 626   FKey := TIdVCardEmbeddedObject.Create;
 627   FComments := PStrList.Create;
 628   FCatagories := PStrList.Create;
 629   FBusinessInfo := TIdVCardBusinessInfo.Create;
 630   FGeography := TIdVCardGeog.Create;
 631   FFullName := TIdVCardName.Create;
 632   FRawForm := PStrList.Create;
 633   FEMailAddresses := TIdVCardEMailAddresses.Create(Self);
 634   FAddresses := TIdVCardAddresses.Create(Self);
 635   FTelephones := TIdVCardTelephones.Create(Self);
 636   FURLs := PStrList.Create;
 637   FMailingLabels := TIdVCardMailingLabels.Create(Self);}
 638 end;
 639 end;
 640
 641 destructor TIdVCard.Destroy;
 642 begin
 643   FreeAndNil(FKey);
 644   FreeAndNil(FPhoto);
 645   FreeAndNil(FLogo);
 646   FreeAndNil(FSound);
 647   FreeAndNil(FComments);
 648   FreeAndNil(FMailingLabels);
 649   FreeAndNil(FCatagories);
 650   FreeAndNil(FBusinessInfo);
 651   FreeAndNil(FGeography);
 652   FreeAndNil(FURLs);
 653   FreeAndNil(FTelephones);
 654   FreeAndNil(FAddresses);
 655   FreeAndNil(FEMailAddresses);
 656   FreeAndNil(FFullName);
 657   FreeAndNil(FRawForm);
 658   inherited;
 659 end;
 660
 661 procedure TIdVCard.ReadFromPStrList(s: PStrList);
 662 var
 663   idx, embedded: Integer;
 664 begin
 665   FRawForm.Clear;
 666   idx := 0;
 667   embedded := 0;
 668   while (idx < s.Count) and
 669     (Trim(UpperCase(s.Items[idx])) <> 'BEGIN:VCARD') do
 670   begin
 671     Inc(idx);
 672   end;
 673   while (idx < s.Count) do
 674   begin
 675     if Length(s.Items[idx]) > 0 then
 676     begin
 677       if UpperCase(Trim(s.Items[idx])) <> 'END:VCARD' then
 678       begin
 679         if embedded <> 0 then
 680         begin
 681           Dec(embedded);
 682         end;
 683       end
 684       else
 685         if UpperCase(Trim(s.Items[idx])) <> 'BEGIN:VCARD' then
 686       begin
 687         Inc(embedded);
 688       end;
 689       FRawForm.Add(s.Items[idx]);
 690     end;
 691     Inc(idx);
 692   end;
 693   if (idx < s.Count) and (Length(s.Items[idx]) > 0) then
 694     FRawForm.Add(s.Items[idx]);
 695   SetVariablesAfterRead;
 696 end;
 697
 698 procedure TIdVCard.SetCatagories(Value: PStrList);
 699 begin
 700   FCatagories.Assign(Value);
 701 end;
 702
 703 procedure TIdVCard.SetComments(Value: PStrList);
 704 begin
 705   FComments.Assign(Value);
 706 end;
 707
 708 procedure TIdVCard.SetURLs(Value: PStrList);
 709 begin
 710   FURLs.Assign(Value);
 711 end;
 712
 713 procedure TIdVCard.SetVariablesAfterRead;
 714 var
 715   idx: Integer;
 716   OrigLine: string;
 717   Line: string;
 718   Attribs: string;
 719   Data: string;
 720   Test: string;
 721   Colon: Integer;
 722   SColon: Integer;
 723   ColonFind: Integer;
 724   QPCoder: TIdQuotedPrintableDecoder;
 725
 726   function UnfoldLines: string;
 727   begin
 728     Result := '';
 729     Inc(idx);
 730     while (idx < FRawForm.Count) and ((Length(FRawForm.Items[idx]) > 0) and
 731       (FRawForm.Items[idx][1] = ' ') or (FRawForm.Items[idx][1] = #9)) do
 732     begin
 733       Result := Result + Trim(FRawForm.Items[idx]);
 734       inc(idx);
 735     end;
 736     Dec(idx);
 737   end;
 738
 739   procedure ProcessAgent;
 740   begin
 741   end;
 742
 743   procedure ParseEmbeddedObject(EmObj: TIdVCardEmbeddedObject; StLn: string);
 744   var
 745     Value: string;
 746     Attribs: PStrList;
 747     idx2: Integer;
 748   begin
 749 {    attribs := GetAttributesAndValue(StLn, Value);
 750     try
 751       idx2 := 0;
 752       while (idx2 < attribs.Count) do
 753       begin
 754         if ((Attribs[idx2] = 'ENCODING=BASE64') or
 755           (Attribs[idx2] = 'BASE64')) then
 756         begin
 757           emObj.Base64Encoded := True;
 758         end
 759         else
 760         begin
 761           if not ((Attribs[idx2] = 'VALUE=URI') or
 762             (Attribs[idx2] = 'VALUE=URL') or
 763             (Attribs[idx2] = 'URI') or
 764             (Attribs[idx2] = 'URL')) then
 765           begin
 766             emObj.ObjectType := Attribs[idx2];
 767           end;
 768         end;
 769         Inc(idx2);
 770       end;
 771       if (Attribs.IndexOf('VALUE=URI') > -1) or
 772         (Attribs.IndexOf('VALUE=URL') > -1) or
 773         (Attribs.IndexOf('URI') > -1) or
 774         (Attribs.IndexOf('URL') > -1) then
 775       begin
 776         emObj.ObjectURL := Value + UnfoldLines;
 777       end
 778       else
 779       begin
 780         AddValueToStrings(EmObj.EmbeddedData, Value);
 781         Inc(idx);
 782         while (idx < FRawForm.Count) and ((Length(FRawForm[idx]) > 0) and
 783           (FRawForm[idx][1] = ' ') or (FRawForm[idx][1] = #9)) do
 784         begin
 785           AddValueToStrings(EmObj.EmbeddedData, Trim(FRawForm[idx2]));
 786           inc(idx);
 787         end;
 788         Dec(idx);
 789       end;
 790     finally
 791       FreeAndNil(Attribs);
 792     end;}
 793   end;
 794
 795 begin
 796
 797 //  QPCoder := TIdQuotedPrintableDecoder.Create(Self);
 798   try
 799
 800     QPCoder.AddCRLF := False;
 801     QPCoder.UseEvent := False;
 802     QPCoder.IgnoreNotification := True;
 803
 804     idx := 0;
 805     while idx < FRawForm.Count do
 806     begin
 807 //      Line := FRawForm[idx];
 808       Colon := Pos(':', Line);
 809       Attribs := Copy(Line, 1, Colon - 1);
 810       if Pos('QUOTED-PRINTABLE', UpperCase(Attribs)) > 0 then
 811       begin
 812         OrigLine := Line;
 813         Data := Copy(Line, Colon + 1, Length(Line));
 814         Inc(idx);
 815 //        ColonFind := Pos(':', FRawForm[idx]);
 816         while ColonFind = 0 do
 817         begin
 818 //          Data := Data + CR + LF + TrimLeft(FRawForm[idx]);
 819           Inc(idx);
 820           if idx <> FRawForm.Count then
 821           begin
 822 //            ColonFind := Pos(':', FRawForm[idx]);
 823           end
 824           else
 825             ColonFind := 1;
 826
 827         end;
 828         Dec(idx);
 829         Test := QPCoder.CodeString(Data);
 830         Data := '';
 831         while Test <> '' do
 832         begin
 833           Fetch(Test, ';');
 834           Data := Data + Test;
 835           Test := QPCoder.GetCodedData;
 836         end;
 837         Test := QPCoder.CompletedInput;
 838         while Test <> '' do
 839         begin
 840           Fetch(Test, ';');
 841           Data := Data + Test;
 842
 843           Test := QPCoder.GetCodedData;
 844         end;
 845         QPCoder.Reset;
 846
 847         ColonFind := Pos(';', Attribs);
 848         Line := '';
 849         while ColonFind <> 0 do
 850         begin
 851           Test := Copy(Attribs, 1, ColonFind);
 852           if Pos('QUOTED-PRINTABLE', Test) = 0 then
 853           begin
 854             Line := Line + Test;
 855           end;
 856           Attribs := Copy(Attribs, ColonFind + 1, Length(Attribs));
 857
 858           ColonFind := Pos(';', Attribs);
 859         end;
 860
 861         if Length(Attribs) <> 0 then
 862         begin
 863           if Pos('QUOTED-PRINTABLE', Attribs) = 0 then
 864           begin
 865             Line := Line + Attribs;
 866           end;
 867         end;
 868         ColonFind := Length(Line);
 869         if ColonFind > 0 then
 870         begin
 871           if Line[ColonFind] = ';' then
 872           begin
 873             Line := Copy(Line, 1, ColonFind - 1);
 874           end;
 875         end;
 876         Line := Line + ':' + Data;
 877       end;
 878       Colon := Pos(':', Line);
 879       SColon := Pos(';', Line);
 880       if (Colon < SColon) or (SColon = 0) then
 881       begin
 882         Line := StringReplace(Line, ':', ';', []);
 883       end;
 884
 885       Test := UpperCase(Fetch(Line, ';'));
 886
 887       case PosInStrArray(Test, VCardProperties) of
 888         0: FFullName.FormattedName := Line + UnfoldLines;
 889         1: ParseName(FFullName, Line + UnfoldLines);
 890         2: ParseDelinatorToPStrList(FFullName.NickNames, Line + UnfoldLines);
 891         3: ParseEmbeddedObject(FPhoto, Line);
 892         4: FBirthDay := ParseDateTimeStamp(Line + UnfoldLines);
 893         5: ParseAddress(FAddresses.Add, Line + UnfoldLines);
 894         6: ParseMailingLabel(FMailingLabels.Add, Line + UnfoldLines);
 895         7: ParseTelephone(FTelephones.Add, Line + UnfoldLines);
 896         8: ParseEMailAddress(FEMailAddresses.Add, Line + UnfoldLines);
 897         9: FEMailProgram := Line + UnfoldLines;
 898         10: FGeography.TimeZoneStr := Line + UnfoldLines;
 899         11: ParseGeography(FGeography, Line + UnfoldLines);
 900         12: FBusinessInfo.Title := Line + UnfoldLines;
 901         13: FBusinessInfo.Role := Line + UnfoldLines;
 902         14: ParseEmbeddedObject(FLogo, Line);
 903         15: ProcessAgent;
 904         16: ParseOrg(FBusinessInfo, Line + UnfoldLines);
 905         17: ParseDelinatorToPStrList(FCatagories, Line + UnfoldLines);
 906         18: FComments.Add(Line + UnfoldLines);
 907         19: FProductID := Line + UnfoldLines;
 908         20: FLastRevised := ParseDateTimeStamp(Line + UnfoldLines);
 909         21: FFullName.SortName := Line + UnfoldLines;
 910         22: ParseEmbeddedObject(FSound, Line);
 911         23: AddValueToStrings(FURLs, Line + UnfoldLines);
 912         24: FUniqueID := Line + UnfoldLines;
 913         25: FVCardVersion := StrToFloat(Line + UnfoldLines);
 914         26: FClassification := Line + UnfoldLines;
 915         27: ParseEmbeddedObject(FKey, Line);
 916       end;
 917       inc(idx);
 918     end;
 919
 920   finally
 921     QPCoder.Free;
 922   end;
 923 end;
 924
 925 function TIdVCardEMailAddresses.Add: TIdVCardEMailItem;
 926 begin
 927 //  Result := TIdVCardEMailItem(inherited Add);
 928 end;
 929
 930 //constructor TIdVCardEMailAddresses.Create(AOwner: TPersistent);
 931 function NewIdVCardEMailAddresses(AOwner: PObj):PIdVCardEMailAddresses;
 932 begin
 933   New( Result, Create );
 934 //  inherited Create(AOwner, TIdVCardEMailItem);
 935 end;
 936
 937 function TIdVCardEMailAddresses.GetItem(Index: Integer): TIdVCardEMailItem;
 938 begin
 939 //  Result := TIdVCardEMailItem(inherited Items[Index]);
 940 end;
 941
 942 procedure TIdVCardEMailAddresses.SetItem(Index: Integer;
 943   const Value: TIdVCardEMailItem);
 944 begin
 945 //  inherited SetItem(Index, Value);
 946 end;
 947
 948 procedure TIdVCardEMailItem.Assign(Source: PObj);
 949 var
 950   EMail: TIdVCardEMailItem;
 951 begin
 952 {  if ClassType <> Source.ClassType then
 953   begin
 954     inherited
 955   end
 956   else
 957   begin
 958     EMail := TIdVCardEMailItem(Source);
 959     EMailType := EMail.EMailType;
 960     Preferred := EMail.Preferred;
 961     Address := EMail.Address;
 962   end;}
 963 end;
 964
 965 //constructor TIdVCardEMailItem.Create(Collection: TCollection);
 966 function NewIdVCardEMailItem(Collection: PCollection):PIdVCardEMailItem;
 967 begin
 968 New( Result, Create );
 969 with Result^ do
 970 //  inherited;
 971   FEMailType := ematInternet;
 972 end;
 973
 974 function TIdVCardAddresses.Add: TIdCardAddressItem;
 975 begin
 976 //  Result := TIdCardAddressItem(inherited Add);
 977 end;
 978
 979 //constructor TIdVCardAddresses.Create(AOwner: TPersistent);
 980 function NewIdVCardAddresses(AOwner: PObj):PIdVCardAddresses;
 981 begin
 982   New( Result, Create );
 983 //  inherited Create(AOwner, TIdCardAddressItem);
 984 end;
 985
 986 function TIdVCardAddresses.GetItem(Index: Integer): TIdCardAddressItem;
 987 begin
 988 //  Result := TIdCardAddressItem(inherited Items[Index]);
 989 end;
 990
 991 procedure TIdVCardAddresses.SetItem(Index: Integer;
 992   const Value: TIdCardAddressItem);
 993 begin
 994 //  inherited SetItem(Index, Value);
 995 end;
 996
 997 function TIdVCardTelephones.Add: TIdCardPhoneNumber;
 998 begin
 999 //  Result := TIdCardPhoneNumber(inherited Add);
1000 end;
1001
1002 //constructor TIdVCardTelephones.Create(AOwner: TPersistent);
1003 function NewIdVCardTelephones(AOwner: PObj):PIdVCardTelephones;
1004 begin
1005   New( Result, Create );
1006 //  inherited Create(AOwner, TIdCardPhoneNumber);
1007 end;
1008
1009 function TIdVCardTelephones.GetItem(Index: Integer): TIdCardPhoneNumber;
1010 begin
1011 //  Result := TIdCardPhoneNumber(inherited Items[Index]);
1012 end;
1013
1014 procedure TIdVCardTelephones.SetItem(Index: Integer;
1015   const Value: TIdCardPhoneNumber);
1016 begin
1017 //  inherited SetItem(Index, Value);
1018 end;
1019
1020 //constructor TIdVCardName.Create;
1021 function NewIdVCardName:PIdVCardName;
1022 begin
1023 //  inherited;
1024 New( Result, Create );
1025 with Result^ do
1026 begin
1027 //  FOtherNames := PStrList.Create;
1028 //  FNickNames := PStrList.Create;
1029 end;
1030 end;
1031
1032 destructor TIdVCardName.Destroy;
1033 begin
1034   FreeAndNil(FNickNames);
1035   FreeAndNil(FOtherNames);
1036   inherited;
1037 end;
1038
1039 procedure TIdVCardName.SetNickNames(Value: PStrList);
1040 begin
1041   FNickNames.Assign(Value);
1042 end;
1043
1044 procedure TIdVCardName.SetOtherNames(Value: PStrList);
1045 begin
1046   FOtherNames.Assign(Value);
1047 end;
1048
1049 //constructor TIdVCardBusinessInfo.Create;
1050 function NewIdVCardBusinessInfo:PIdVCardBusinessInfo;
1051 begin
1052   New( Result, Create );
1053 with Result^ do
1054 begin
1055 //  inherited;
1056 //  FDivisions := PStrList.Create;
1057 end;
1058 end;
1059
1060 destructor TIdVCardBusinessInfo.Destroy;
1061 begin
1062   FreeAndNil(FDivisions);
1063   inherited;
1064 end;
1065
1066 procedure TIdVCardBusinessInfo.SetDivisions(Value: PStrList);
1067 begin
1068   FDivisions.Assign(Value);
1069 end;
1070
1071 procedure TIdVCardMailingLabelItem.Assign(Source: PObj);
1072 var
1073   lbl: TIdVCardMailingLabelItem;
1074 begin
1075 {  if ClassType <> Source.ClassType then
1076   begin
1077     inherited
1078   end
1079   else
1080   begin
1081     lbl := TIdVCardMailingLabelItem(Source);
1082     AddressAttributes := lbl.AddressAttributes;
1083     MailingLabel.Assign(lbl.MailingLabel);
1084   end;}
1085 end;
1086
1087 //constructor TIdVCardMailingLabelItem.Create(Collection: TCollection);
1088 function NewIdVCardMailingLabelItem(Collection: PCollection):PIdVCardMailingLabelItem;
1089 begin
1090   New( Result, Create );
1091 with Result^ do
1092 begin
1093 //  inherited;
1094 //  FMailingLabel := PStrList.Create;
1095 end;
1096 end;
1097
1098 destructor TIdVCardMailingLabelItem.Destroy;
1099 begin
1100   FreeAndNil(FMailingLabel);
1101   inherited;
1102 end;
1103
1104 procedure TIdVCardMailingLabelItem.SetMailingLabel(Value: PStrList);
1105 begin
1106   FMailingLabel.Assign(Value);
1107 end;
1108
1109 function TIdVCardMailingLabels.Add: TIdVCardMailingLabelItem;
1110 begin
1111 //  Result := TIdVCardMailingLabelItem(inherited Add);
1112 end;
1113
1114 //constructor TIdVCardMailingLabels.Create(AOwner: TPersistent);
1115 function NewIdVCardMailingLabels(AOwner: PObj):PIdVCardMailingLabels;
1116 begin
1117   New( Result, Create );
1118 //  inherited Create(AOwner, TIdVCardMailingLabelItem);
1119 end;
1120
1121 function TIdVCardMailingLabels.GetItem(
1122   Index: Integer): TIdVCardMailingLabelItem;
1123 begin
1124 //  Result := TIdVCardMailingLabelItem(inherited GetItem(Index));
1125 end;
1126
1127 procedure TIdVCardMailingLabels.SetItem(Index: Integer;
1128   const Value: TIdVCardMailingLabelItem);
1129 begin
1130 //  inherited SetItem(Index, Value);
1131 end;
1132
1133 //constructor TIdVCardEmbeddedObject.Create;
1134 function NewIdVCardEmbeddedObject:PIdVCardEmbeddedObject;
1135 begin
1136   New( Result, Create );
1137 with Result^ do
1138 begin
1139 //  inherited;
1140 //  FEmbeddedData := PStrList.Create;
1141 end;
1142 end;
1143
1144 destructor TIdVCardEmbeddedObject.Destroy;
1145 begin
1146   FreeAndNil(FEmbeddedData);
1147   inherited;
1148 end;
1149
1150 procedure TIdVCardEmbeddedObject.SetEmbeddedData(const Value: PStrList);
1151 begin
1152   FEmbeddedData.Assign(Value);
1153 end;
1154
1155 procedure TIdCardPhoneNumber.Assign(Source: PObj);
1156 var
1157   Phone: TIdCardPhoneNumber;
1158 begin
1159 {  if ClassType <> Source.ClassType then
1160   begin
1161     inherited;
1162   end
1163   else
1164   begin
1165     Phone := TIdCardPhoneNumber(Source);
1166     PhoneAttributes := Phone.PhoneAttributes;
1167     Number := Phone.Number;
1168   end;}
1169 end;
1170
1171 procedure TIdCardAddressItem.Assign(Source: PObj);
1172 var
1173   Addr: TIdCardAddressItem;
1174 begin
1175 {  if ClassType <> Source.ClassType then
1176   begin
1177     inherited;
1178   end
1179   else
1180   begin
1181     Addr := TIdCardAddressItem(Source);
1182     AddressAttributes := Addr.AddressAttributes;
1183     POBox := Addr.POBox;
1184     ExtendedAddress := Addr.ExtendedAddress;
1185     StreetAddress := Addr.StreetAddress;
1186     Locality := Addr.Locality;
1187     Region := Addr.Region;
1188     PostalCode := Addr.PostalCode;
1189     Nation := Addr.Nation;
1190   end;}
1191 end;
1192
1193 function NewIdVCardGeog:PIdVCardGeog;
1194 begin
1195   New( Result, Create );
1196 end;
1197
1198 function NewIdCardPhoneNumber:PIdCardPhoneNumber;
1199 begin
1200   New( Result, Create );
1201 end;
1202
1203 function NewIdCardAddressItem:PIdCardAddressItem;
1204 begin
1205   New( Result, Create );
1206 end;
1207
1208 end.