idvcard.pas

Indy控件的使用源代码

              LabelObj.AddressAttributes + [ tatPreferred ];
      end;
      inc ( idx );
    end;  //while idx < Attribs.Count do
    {Default Values}
    if Attribs.Count = 0 then
    begin
      LabelObj.AddressAttributes := [ tatInternational,  tatPostal, tatParcel, tatWork ];
    end; //if Attribs.Count = 0 then
    LabelObj.MailingLabel.Add ( Value );
  finally
    FreeAndNil ( Attribs );
  end;  //try..finally
end;

{This parses the Name and places the name in the TIdVCardName}
Procedure ParseName ( NameObj : TIdVCardName; NameStr : String );
var OtherNames : String;

begin
  { surname }
  NameObj.SurName := Fetch ( NameStr, ';' );    {Do not Localize}
  { first name }
  NameObj.FirstName := Fetch ( NameStr, ';' );    {Do not Localize}
  { middle and other names}
  OtherNames := Fetch ( NameStr, ';' );    {Do not Localize}
  { Prefix }
  NameObj.Prefix := Fetch ( NameStr, ';' );    {Do not Localize}
  { Suffix }
  NameObj.Suffix := Fetch ( NameStr, ';' );    {Do not Localize}
  OtherNames := StringReplace( OtherNames, ' ', ',', [ rfReplaceAll ] );    {Do not Localize}
  ParseDelinatorToTStrings (  NameObj.OtherNames, OtherNames);
end;

{This parses EMailStr and places the attributes in EMailObj }
Procedure ParseEMailAddress ( EMailObj : TIdVCardEMailItem; EMailStr : String);
var Value : String;
    Attribs : TStringList;
    idx : Integer;
    {this is for testing the type so we can break out of the loop}
    ps : Integer;
begin
  Attribs := GetAttributesAndValue ( EMailStr, Value );
  try
    EMailObj.Address := Value;
    EMailObj.Preferred := (attribs.IndexOf( 'PREF' ) <> -1 );    {Do not Localize}
    idx := 0;
    ps := -1;
    while (idx < Attribs.Count ) and (ps = -1) do
    begin
      ps := PosInStrArray( Attribs [ idx ], EMailTypePropertyParameter );
      case ps of
        0 : EMailObj.EMailType := ematAOL; {America On-Line}
        1 : EMailObj.EMailType := ematAppleLink; {AppleLink}
        2 : EMailObj.EMailType := ematATT;   { AT&T Mail }
        3 : EMailObj.EMailType := ematCIS;   { CompuServe Information Service }
        4 : EMailObj.EMailType := emateWorld; { eWorld }
        5 : EMailObj.EMailType := ematInternet; {Internet SMTP (default)}
        6 : EMailObj.EMailType := ematIBMMail; { IBM Mail }
        7 : EMailObj.EMailType := ematMCIMail; { Indicates MCI Mail }
        8 : EMailObj.EMailType := ematPowerShare; { PowerShare }
        9 : EMailObj.EMailType := ematProdigy; { Prodigy information service }
       10 : EMailObj.EMailType := ematTelex; { Telex number }
       11 : EMailObj.EMailType := ematX400; { X.400 service }
      end; // case ps of
      inc ( idx );
    end; // while (idx < Attribs.Count ) do
  finally
    FreeAndNil ( Attribs );
  end;  //try..finally
end;

{ TIdVCard }

constructor TIdVCard.Create(AOwner: TComponent);
begin
  inherited;
  FPhoto := TIdVCardEmbeddedObject.Create;
  FLogo  := TIdVCardEmbeddedObject.Create;
  FSound := TIdVCardEmbeddedObject.Create;
  FKey := TIdVCardEmbeddedObject.Create;
  FComments := TStringList.Create;
  FCategories := TStringList.Create;
  FBusinessInfo := TIdVCardBusinessInfo.Create;
  FGeography := TIdVCardGeog.Create;
  FFullName := TIdVCardName.Create;
  FRawForm := TStringList.Create;
  FEMailAddresses := TIdVCardEMailAddresses.Create ( Self );
  FAddresses := TIdVCardAddresses.Create ( Self );
  FTelephones := TIdVCardTelephones.Create ( Self );
  FURLs := TStringList.Create;
  FMailingLabels := TIdVCardMailingLabels.Create ( Self );
end;

destructor TIdVCard.Destroy;
begin
  FreeAndNil ( FKey );
  FreeAndNil ( FPhoto );
  FreeAndNil ( FLogo );
  FreeAndNil ( FSound );
  FreeAndNil ( FComments );
  FreeAndNil ( FMailingLabels );
  FreeAndNil ( FCategories );
  FreeAndNil ( FBusinessInfo );
  FreeAndNil ( FGeography );
  FreeAndNil ( FURLs );
  FreeAndNil ( FTelephones );
  FreeAndNil ( FAddresses );
  FreeAndNil ( FEMailAddresses );
  FreeAndNil ( FFullName );
  FreeAndNil ( FRawForm );
  inherited;
end;

procedure TIdVCard.ReadFromTStrings(s: TStrings);
var
  idx, embedded : Integer;
begin
  FRawForm.Clear;
  {Find the begin mark and accomodate broken VCard implemntations}
  idx := 0;
  embedded := 0;
  while ( idx < s.Count ) and
    ( Trim ( UpperCase ( s [ idx ] ) ) <> 'BEGIN:VCARD' ) do    {Do not Localize}
  begin
    Inc ( idx );
  end;  //while ..
  {Keep adding until end VCard }
  while ( idx < s.Count ) do
  begin
    if Length ( s [idx] ) > 0 then
    begin
      if UpperCase ( Trim ( s [ idx ] ) ) <> 'END:VCARD' then    {Do not Localize}
      begin
        // Have an END: - check if this is embedded
        if embedded <> 0 then
        begin
          // Yes - decrement the counter & add
          Dec(embedded);
        end;
      end else if UpperCase ( Trim ( s [ idx ] ) ) <> 'BEGIN:VCARD' then    {Do not Localize}
      begin
        // Have a new embedded object - increment the counter & add
        Inc(embedded);
      end;
      // Regardless of content - add it
      FRawForm.Add(s[idx]);
    end;
    Inc ( idx );
  end; //while ( idx < s.Count ) and (s[idx] <> 'END:VCARD') do    {Do not Localize}
  if  ( idx < s.Count ) and (Length(s [idx] ) > 0 ) then
    FRawForm.Add ( s [ idx ] );
  SetVariablesAfterRead;
end;

procedure TIdVCard.SetCategories(Value: TStrings);
begin
  FCategories.Assign(Value);
end;

procedure TIdVCard.SetComments(Value: TStrings);
begin
  FComments.Assign(Value);
end;

procedure TIdVCard.SetURLs(Value: TStrings);
begin
  FURLs.Assign(Value);
end;

procedure TIdVCard.SetVariablesAfterRead;
var idx : Integer;
    OrigLine : String;
    Line : String;
    Attribs : String;
    Data : String;
    Test : String;
    Colon : Integer;
    SColon : Integer;
    ColonFind : Integer;
    QPCoder : TIdDecoderQuotedPrintable;

    {These subroutines increment idx to prevent unneded comparisons of folded
    lines}

    Function UnfoldLines : String;
    begin
      Result := '';    {Do not Localize}
      Inc ( idx );
      while ( idx < FRawForm.Count ) and ( ( Length ( FRawForm [ idx ] ) > 0) and
        (  FRawForm [ idx ] [ 1 ] = ' ' ) or (  FRawForm [ idx ] [ 1 ] = #9 ) ) do    {Do not Localize}
      begin
        Result := Result + Trim ( FRawForm [ idx ] );
        inc ( idx );
      end; // while
      {Correct for increment in the main while loop}
      Dec ( idx );
    end;

    procedure ProcessAgent;
    begin
      // The current idx of FRawForm could be an embedded vCard.
      { TODO : Eliminate embedded vCard }
    end;

    Procedure ParseEmbeddedObject(EmObj : TIdVCardEmbeddedObject; StLn : String);
    var Value : String;
        Attribs : TStringList;
        idx2 : Integer;
       {this is for testing the type so we can break out of the loop}
    begin
      attribs := GetAttributesAndValue ( StLn, Value );
      try
        idx2 := 0;
        while ( idx2 < attribs.Count ) do
        begin
          if  ((Attribs[ idx2 ] = 'ENCODING=BASE64') or    {Do not Localize}
            (Attribs [ idx2 ] = 'BASE64')) then    {Do not Localize}
          begin
            emObj.Base64Encoded := True;
          end   //if
          else
          begin
            if not (( Attribs [ idx2 ] = 'VALUE=URI' ) or    {Do not Localize}
               ( Attribs [ idx2 ] = 'VALUE=URL' ) or    {Do not Localize}
               ( Attribs [ idx2 ] = 'URI' ) or    {Do not Localize}
               ( Attribs [ idx2 ] = 'URL' ) ) then    {Do not Localize}
            begin
              emObj.ObjectType := Attribs [ idx2 ];
            end;   // if NOT ...
          end; // else if not ..
          Inc ( idx2 );
        end; //while ( idx2 < attribs.Count ) do
        if ( Attribs.IndexOf ( 'VALUE=URI' ) > -1 ) or    {Do not Localize}
          ( Attribs.IndexOf ( 'VALUE=URL' ) > -1 ) or    {Do not Localize}
          ( Attribs.IndexOf ( 'URI' ) > -1 ) or    {Do not Localize}
          ( Attribs.IndexOf ( 'URL' ) > -1 )  then    {Do not Localize}
        begin
          emObj.ObjectURL := Value + UnfoldLines;
        end  //if
        else
        begin
          AddValueToStrings ( EmObj.EmbeddedData, Value );
          {Add any folded lines}
          Inc( idx );
          while ( idx < FRawForm.Count ) and ( ( Length ( FRawForm [ idx ] ) > 0) and
           ( FRawForm [ idx ] [ 1 ] = ' ' ) or (  FRawForm [ idx ] [ 1 ] = #9 ) ) do    {Do not Localize}
          begin
            AddValueToStrings (  EmObj.EmbeddedData, Trim ( FRawForm [ idx2 ] ) );
            inc ( idx );
          end; // while
          {Correct for increment in the main while loop}
          Dec ( idx );
        end; // else .. if
      finally
        FreeAndNil ( Attribs );
      end;
    end;

begin
  // At this point, FRawForm contains the entire vCard - including possible
  // embedded vCards.

  QPCoder := TIdDecoderQuotedPrintable.Create(Self);
  try

  idx := 0;
  while idx < FRawForm.Count do
  begin
    // Grab the line
    Line := FRawForm [ idx ];

    {We separate the property name from the parameters and values here.
     We have be careful because sometimes a property in a vCard is separed by a
     ; or : even if the RFC and standards don't permit this   
     - broken VCard creation tools }
    Colon := IndyPos(':', Line);    {Do not Localize}

    // Store the property & complete attributes
    Attribs := Copy(Line, 1, Colon - 1);

    // Must now check for Quoted-printable attribute.  vCard v2.1 allows
    // QP to be used in any field.

    //****  Begin QP check & decode
    if IndyPos('QUOTED-PRINTABLE', UpperCase(Attribs)) > 0 then    {Do not Localize}
    begin
      // First things first - make a copy of the Line.
      OrigLine := Line;

      // Set Data to be the data contained on this line of the vCard
      Data := Copy(Line, Colon + 1, Length(Line));

      // The problem with QP-embedded objects is that the Colon character is
      // not standard QP-encoded... however, it is the only reliable way to
      // discover the next property.  So loop here until the next property is
      // found (i.e., the next line with a colon).
      Inc(idx);
      ColonFind := IndyPos(':', FRawForm[idx]);    {Do not Localize}
      while ColonFind = 0 do
      begin
        Data := Data + TrimLeft(FRawForm[idx]);

        Inc(idx);
        if idx <> FRawForm.Count then
        begin
          ColonFind := IndyPos(':', FRawForm[idx]);    {Do not Localize}
        end else ColonFind := 1;

      end;
      // Return idx to this property's (last) line    {Do not Localize}
      Dec(idx);

      Data := QPCoder.DecodeToString(Data);

      // Now reorganise property so that it does not have a QP attribute.
      ColonFind := IndyPos(';', Attribs);    {Do not Localize}
      Line := '';    {Do not Localize}
      while ColonFind <> 0 do
      begin
        Test := Copy(Attribs, 1, ColonFind);
        if IndyPos('QUOTED-PRINTABLE', UpperCase(Test)) = 0 then    {Do not Localize}
        begin
          // Add to Line.
          Line := Line + Test;
        end;
        Attribs := Copy(Attribs, ColonFind + 1, Length(Attribs));

        ColonFind := IndyPos(';', Attribs);    {Do not Localize}
      end;

      // Clean up variables
      if Length(Attribs) <> 0 then
      begin
        // Does Quoted-Printable occur in what's left?    {Do not Localize}
        if IndyPos('QUOTED-PRINTABLE', UpperCase(Attribs)) = 0 then    {Do not Localize}
        begin
          // Add to line
          Line := Line + Attribs;
        end;
      end;

      // Check if the last char of Line is a semi-colon.  If so, remove it.
      ColonFind := Length(Line);
      If ColonFind > 0 then