Download fixed wideidemailaddress.pas

unit WideIdEMailAddress;
 
interface
 
uses
  Classes, TntClasses;
 
type
  TWideIdEMailAddressItem = class(TCollectionItem)
  protected
    FAddress: Widestring;
    FName: Widestring;
    function GetText: Widestring;
    procedure SetText(AText: Widestring);
    function ConvertAddress: Widestring;
    function GetDomain: Widestring;
    procedure SetDomain(const ADomain: Widestring);
    function GetUsername: Widestring;
    procedure SetUsername(const AUsername: Widestring);
  public
    procedure Assign(Source: TPersistent); override;
  published
     {This is the E-Mail address itself }
    property Address: Widestring read FAddress write FAddress;
     {This is the person's name}{Do not Localize}
    property Name: Widestring read FName write FName;
     {This is the combined person's name and E-Mail address}{Do not Localize}
    property Text: Widestring read GetText write SetText;
     {Extracted domain for some types of E-Mail processing}
    property Domain: Widestring read GetDomain write SetDomain;
    property User: Widestring read GetUsername write SetUsername;
  end;
 
  TWideIdEMailAddressList = class(TOwnedCollection)
  protected
    function GetItem(Index: Integer): TWideIdEMailAddressItem;
    procedure SetItem(Index: Integer; const Value: TWideIdEMailAddressItem);
    function GetEMailAddresses: Widestring;
    procedure SetEMailAddresses(AList: Widestring);
  public
    constructor Create(AOwner: TPersistent); reintroduce;
 
     {This returns formatted list of formated
     addresses including the names from the collection }
    procedure FillTStrings(AStrings: TTntStrings);
    function Add: TWideIdEMailAddressItem;
     //get all of the domains in the list so we can process those individually with
     //TIdDirectSMTP
    procedure GetDomains(AStrings: TTntStrings);
     {Sort by domains for making it easier to process E-Mails directly in
     TIdDirectSMTP}
    procedure SortByDomain;
     //Get all of the E-Mail addresses for a particular domain so we can
     //send E-Mail to recipients at one domain with only one connection for
     //speed with TIdDirectSMTP.
    procedure AddressesByDomain(AList: TWideIdEMailAddressList; const ADomain: Widestring);
    property Items[Index: Integer]: TWideIdEMailAddressItem read GetItem write SetItem; default;
     {This is a comma separated list of formated
     addresses including the names from the collection }
    property EMailAddresses: Widestring read GetEMailAddresses write SetEMailAddresses;
  end;
 
const
  WideTab: widechar = #9;
 
implementation
 
uses
  SysUtils, TntSysUtils;
 
const
  // This is actually the ATEXT without the '"' and space characters...    {Do not Localize}
  IETF_ATEXT: Widestring = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ' {Do not Localize}
  + '1234567890!#$%&''*+-/=?_`{}|~'; {Do not Localize}
  // ATEXT without the '"'    {Do not Localize}
  IETF_ATEXT_SPACE: Widestring = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ' {Do not Localize}
  + '1234567890!#$%&''*+-/=?_`{}|~ '; {Do not Localize}
  IETF_QUOTABLE: Widestring = '\"'; {Do not Localize}
 
// Three functions for easier manipulating of strings.
// Don't know of any system functions to perform these actions.    {Do not Localize}
// If there aren't & someone can find an optimised way of performing    {Do not Localize}
// then please implement...
 
function FindFirstOf(const AFind, AText: Widestring): Integer;
var
  nCount, nPos: Integer;
begin
  Result := 0;
  for nCount := 1 to Length(AFind) do begin
    nPos := Pos(AFind[nCount], AText);
    if nPos > 0 then begin
      if Result = 0 then begin
        Result := nPos;
      end else if Result > nPos then begin
        Result := nPos;
      end;
    end;
  end;
end;
 
function FindFirstNotOf(const AFind, AText: Widestring): Integer;
var
  i: Integer;
begin
  Result := 0;
  if AFind = '' then
  begin
    Result := 1;
    Exit;
  end;
 
  if AText = '' then
  begin
    Exit;
  end;
 
  for i := 1 to Length(AText) do
  begin
    if Pos(AText[i], AFind) = 0 then
    begin
      Result := i;
      Exit;
    end;
  end;
end;
 
function TrimAllOf(const ATrim, AText: Widestring): Widestring;
var
  Len: Integer;
begin
  Result := AText;
  Len := Length(Result);
  while Len > 0 do
  begin
    if Pos(Result[1], ATrim) > 0 then
    begin
      Delete(Result, 1, 1);
      Dec(Len);
    end else Break;
  end;
  while Len > 0 do begin
    if Pos(Result[Len], ATrim) > 0 then
    begin
      Delete(Result, Len, 1);
      Dec(Len);
    end else Break;
  end;
end;
 
{ TWideIdEMailAddressItem }
 
procedure TWideIdEMailAddressItem.Assign(Source: TPersistent);
var Addr: TWideIdEMailAddressItem;
begin
  if ClassType <> Source.ClassType then
  begin
    inherited
  end
  else
  begin
    Addr := TWideIdEMailAddressItem(Source);
    Address := Addr.Address;
    Name := Addr.Name;
  end;
end;
 
function TWideIdEMailAddressItem.ConvertAddress: Widestring;
var
  i: Integer;
  domainPart, tempAddress, localPart: Widestring;
begin
  if FAddress = '' then
  begin
    if FName <> '' then
    begin
      Result := '<>'; {Do not Localize}
    end else
    begin
      Result := ''; {Do not Localize}
    end;
    Exit;
  end;
 
  // First work backwards to the @ sign.
  tempAddress := FAddress;
  domainPart := '';
  for i := Length(FAddress) downto 1 do
  begin
    if FAddress[i] = '@' then {Do not Localize}
    begin
      domainPart := Copy(FAddress, i, MaxInt);
      tempAddress := Copy(FAddress, 1, i - 1);
      Break;
    end;
  end;
 
  i := FindFirstNotOf(IETF_ATEXT, tempAddress);
  if (i = 0) or (Copy(tempAddress, i, 1) = #46) then //hack to accomodate periods in emailaddress
//  if i = 0 then
  begin
    if FName <> '' then
    begin
      Result := '<' + tempAddress + domainPart + '>'; {Do not Localize}
    end else
    begin
      Result := tempAddress + domainPart;
    end;
  end else
  begin
    localPart := '"'; {Do not Localize}
    while i > 0 do
    begin
      localPart := localPart + Copy(tempAddress, 1, i - 1);
      if Pos(tempAddress[i], IETF_QUOTABLE) > 0 then
      begin
        localPart := localPart + '\'; {Do not Localize}
      end;
      localPart := localPart + tempAddress[i];
      System.Delete(tempAddress, 1, i);
      i := FindFirstNotOf(IETF_ATEXT, tempAddress);
    end;
    Result := '<' + localPart + tempAddress + '"' + domainPart + '>'; {Do not Localize}
  end;
end;
 
function TWideIdEMailAddressItem.GetDomain: Widestring;
var i: Integer;
begin
  Result := '';
  for i := Length(FAddress) downto 1 do
  begin
    if FAddress[i] = '@' then {Do not Localize}
    begin
      Result := Copy(FAddress, i + 1, MaxInt);
      Break;
    end;
  end;
end;
 
procedure TWideIdEMailAddressItem.SetDomain(const ADomain: Widestring);
var
  Result: Widestring;
begin
  Result := FAddress;
  Delete(Result, Pos('@', Result) - 1, Length(Result));
  Result := Result + '@' + ADomain;
  FAddress := Result;
end;
 
function TWideIdEMailAddressItem.GetUsername: Widestring;
var i: Integer;
begin
  Result := '';
  for i := Length(FAddress) downto 1 do
  begin
    if FAddress[i] = '@' then {Do not Localize}
    begin
      Result := Copy(FAddress, 1, i - 1);
      Break;
    end;
  end;
end;
 
procedure TWideIdEMailAddressItem.SetUsername(const AUsername: Widestring);
var
  Result: Widestring;
begin
  Result := FAddress;
  Delete(Result, 1, Pos('@', Result) + 1);
  Result := AUsername + '@' + Result;
  FAddress := Result;
end;
 
function TWideIdEMailAddressItem.GetText: Widestring;
var
  i: Integer;
  tempName, resName: Widestring;
begin
  if (FName <> '') and (UpperCase(FAddress) <> FName) then
  begin
    i := FindFirstNotOf(IETF_ATEXT_SPACE, FName);
    if i > 0 then
    begin
      // Need to quote the FName.
      resName := '"' + Copy(FName, 1, i - 1); {Do not Localize}
      if Pos(FName[i], IETF_QUOTABLE) > 0 then
      begin
        resName := resName + '\'; {Do not Localize}
      end;
      resName := resName + FName[i];
 
      tempName := Copy(FName, i + 1, MaxInt);
      while tempName <> '' do
      begin
        i := FindFirstNotOf(IETF_ATEXT_SPACE, tempName);
        if i = 0 then
        begin
          Result := resName + tempName + '" ' + ConvertAddress; {Do not Localize}
          Exit;
        end;
        resName := resName + Copy(tempName, 1, i - 1);
        if Pos(tempName[i], IETF_QUOTABLE) > 0 then
        begin
          resName := resName + '\'; {Do not Localize}
        end;
        resName := resName + tempName[i];
        System.Delete(tempName, 1, i);
      end;
      Result := resName + '" ' + ConvertAddress; {Do not Localize}
    end else
    begin
      Result := FName + ' ' + ConvertAddress; {Do not Localize}
    end;
  end //  if
  else
  begin
    Result := ConvertAddress;
  end; // else .. if
end;
 
procedure TWideIdEMailAddressItem.SetText(AText: Widestring);
var
  nFirst,
    nBracketCount: Integer;
  bInAddress,
    bAddressInLT,
    bAfterAt,
    bInQuote: Boolean;
begin
  FAddress := ''; {Do not Localize}
  FName := ''; {Do not Localize}
 
  AText := Trim(AText);
  if AText = '' then
    Exit;
 
  // Find the first known character type.
  nFirst := FindFirstOf('("< @' + WideTab, AText); {Do not Localize}
  if nFirst <> 0 then
  begin
    nBracketCount := 0;
    bInAddress := False;
    bAddressInLT := False;
    bInQuote := False;
    bAfterAt := False;
    repeat
      case AnsiChar(AText[nFirst]) of
        ' ', #9: {Do not Localize}
          begin
            if nFirst = 1 then
            begin
              Delete(AText, 1, 1);
            end else
            begin
            // Only valid if in a name not contained in quotes - keep the space.
              if bAfterAt then begin
                FAddress := FAddress + Trim(Copy(AText, 1, nFirst - 1));
              end else begin
                FName := FName + Copy(AText, 1, nFirst);
              end;
              System.Delete(AText, 1, nFirst);
            end;
          end;
        '(': {Do not Localize}
          begin
            Inc(nBracketCount);
            if (nFirst > 1) then
            begin
            // There's at least one character to the name    {Do not Localize}
              if bInAddress then
              begin
                FAddress := FAddress + Trim(Copy(AText, 1, nFirst - 1));
              end else
              begin
                if nBracketCount = 1 then
                begin
                  FName := FName + Copy(AText, 1, nFirst - 1);
                end;
              end;
              System.Delete(AText, 1, nFirst);
            end else
            begin
              Delete(AText, 1, 1);
            end;
          end;
        ')': {Do not Localize}
          begin
            Dec(nBracketCount);
            System.Delete(AText, 1, nFirst);
          end;
        '"': {Do not Localize}
          begin
            if bInQuote then
            begin
              if bAddressInLT then
              begin
                FAddress := FAddress + Trim(Copy(AText, 1, nFirst - 1));
              end else
              begin
                FName := FName + Trim(Copy(AText, 1, nFirst - 1));
              end;
              System.Delete(AText, 1, nFirst);
              bInQuote := False;
            end else
            begin
              bInQuote := True;
              Delete(AText, 1, 1);
            end;
          end;
        '<': {Do not Localize}
          begin
            if nFirst > 1 then
            begin
              FName := FName + Copy(AText, 1, nFirst - 1);
            end;
            FName := TrimAllOf(' ' + #9, Trim(FName)); {Do not Localize}
            bAddressInLT := True;
            bInAddress := True;
            Delete(AText, 1, nFirst);
          end;
        '>': {Do not Localize}
          begin
          // Only searched for if the address starts with '<'    {Do not Localize}
            bInAddress := False;
            bAfterAt := False;
            FAddress := FAddress +
              TrimAllOf(' ' + #9, Trim(Copy(AText, 1, nFirst - 1))); {Do not Localize}
            System.Delete(AText, 1, nFirst);
          end;
        '@': {Do not Localize}
          begin
            bAfterAt := True;
            if bInAddress then
            begin
              FAddress := FAddress + Copy(AText, 1, nFirst);
              System.Delete(AText, 1, nFirst);
            end else
            begin
              if bAddressInLT then
              begin
              // Strange use. For now raise an exception until a real-world
              // example can be found.
              // Basically, it's formatted as follows:    {Do not Localize}
              //    <someguy@domain.example> some-text @ some-text
              // or:
              //    some-text <someguy@domain.example> some-text @ some-text
              // where some text may be blank.
              //CC: Note you used to arrive here if the From header in an email
              //included more than one address (which was subsequently changed)
              //because our code did not parse the From header for multiple
              //addresses.  That may have been the reason for this code.
//              raise EIdEmailParseError.Create(RSEMailSymbolOutsideAddress);
                fName := fName + AText;
                Exit;
              end else
              begin
              // If at this point, we're either supporting an e-mail address    {Do not Localize}
              // on it's own, or the old-style valid format:    {Do not Localize}
              //    "Name" name@domain.example
                bInAddress := True;
                FAddress := FAddress + Copy(AText, 1, nFirst);
                System.Delete(AText, 1, nFirst);
              end;
            end;
          end;
        '.': {Do not Localize}
          begin
          // Must now be a part of the domain part of the address.
            if bAddressInLT then
            begin
            // Whitespace is possible around the parts of the domain.
              FAddress := FAddress +
                TrimAllOf(' ' + #9, Trim(Copy(AText, 1, nFirst - 1))) + '.'; {Do not Localize}
              AText := TrimLeft(Copy(AText, nFirst + 1, MaxInt));
            end else
            begin
            // No whitespace is allowed if no wrapping <> characters.
              FAddress := FAddress + Copy(AText, 1, nFirst);
              System.Delete(AText, 1, nFirst);
            end;
          end;
        '\': {Do not Localize}
          begin
          // This will only be discovered in a bracketted or quoted section.
          // It's an escape character indicating the next cahracter is    {Do not Localize}
          // a literal.
            if bInQuote then
            begin
            // Need to retain the second character
              if bInAddress then
              begin
                FAddress := FAddress + Copy(AText, 1, nFirst - 1);
                FAddress := FAddress + AText[nFirst + 1];
              end else
              begin
                FName := FName + Copy(AText, 1, nFirst - 1);
                FName := FName + AText[nFirst + 1];
              end;
            end;
            System.Delete(AText, 1, nFirst + 1);
          end;
      end;
 
 
      // Check for bracketted sections first: ("<>" <> "" <"">) - all is ignored
      if nBracketCount > 0 then
      begin
        // Inside a bracket, only three charatcers are special.
        // '(' Opens a nested bracket: (One (Two (Three )))    {Do not Localize}
        // ')' Closes a bracket    {Do not Localize}
        // '/' Escape character: (One /) /( // (Two /) ))    {Do not Localize}
        nFirst := FindFirstOf('()\', AText); {Do not Localize}
 
      // Check if in quote before address: <"My Name"@domain.example> is valid
      end else if bInQuote then
      begin
      // Inside quotes, only the end quote and escape character are special.
        nFirst := FindFirstOf('"\', AText); {Do not Localize}
 
      // Check if after the @ of the address: domain.example>
      end else if bAfterAt then
      begin
        if bAddressInLT then
        begin
          // If the address is enclosed, then only the '(', '.' & '>' need be    {Do not Localize}
          // looked for, trimming all content when found: domain  .  example >
          nFirst := FindFirstOf('.>(', AText); {Do not Localize}
        end else
        begin
          nFirst := FindFirstOf('.( ', AText); {Do not Localize}
        end;
 
      // Check if in address: <name@domain.example>
      end else if bInAddress then
      begin
        nFirst := FindFirstOf('"(@>', AText); {Do not Localize}
 
      // Not in anything - check for opening charactere
      end else
      begin
        // Outside brackets
        nFirst := FindFirstOf('("< @' + WideTab, AText); {Do not Localize}
      end;
    until nFirst = 0;
    if bInAddress and not bAddressInLT then
    begin
      FAddress := FAddress + TrimAllOf(' ' + #9, Trim(AText)); {Do not Localize}
    end;
  end else
  begin
    // No special characters, so assume a simple address
    FAddress := AText;
  end;
end;
 
 
 
{ TWideIdEMailAddressList }
 
function TWideIdEMailAddressList.Add: TWideIdEMailAddressItem;
begin
  Result := TWideIdEMailAddressItem(inherited Add);
end;
 
constructor TWideIdEMailAddressList.Create(AOwner: TPersistent);
begin
  inherited Create(AOwner, TWideIdEMailAddressItem);
end;
 
procedure TWideIdEMailAddressList.FillTStrings(AStrings: TTntStrings);
var
  idx: Integer;
begin
  for idx := 0 to Count - 1 do
  begin
    AStrings.Add(GetItem(idx).Text);
  end;
end;
 
function TWideIdEMailAddressList.GetItem(Index: Integer): TWideIdEMailAddressItem;
begin
  Result := TWideIdEMailAddressItem(inherited Items[Index]);
end;
 
function TWideIdEMailAddressList.GetEMailAddresses: Widestring;
var
  idx: Integer;
begin
  Result := ''; {Do not Localize}
  for idx := 0 to Count - 1 do
  begin
    if Result = '' then
      Result := GetItem(idx).Text
    else
      Result := Result + ', ' + GetItem(idx).Text; {Do not Localize}
  end;
end;
 
procedure TWideIdEMailAddressList.SetItem(Index: Integer;
  const Value: TWideIdEMailAddressItem);
begin
  inherited SetItem(Index, Value);
end;
 
procedure TWideIdEMailAddressList.SetEMailAddresses(AList: Widestring);
var
  EMail: TWideIdEMailAddressItem;
  iStart: Integer;
  sTemp: Widestring;
  nInBracket: Integer;
  bInQuote: Boolean;
begin
  Clear;
 
  if (Trim(AList) = '') then Exit; {Do not Localize}
 
  iStart := FindFirstOf(':;(", ' + WideTab, AList); {Do not Localize}
  if iStart = 0 then begin
    EMail := Add;
    EMail.Text := TrimLeft(AList);
  end else begin
    sTemp := ''; {Do not Localize}
    nInBracket := 0;
    bInQuote := False;
    repeat
      case AList[iStart] of
        ' ', #9: begin {Do not Localize}
            if iStart = 1 then begin
              sTemp := sTemp + AList[iStart];
              System.Delete(AList, 1, 1);
            end else begin
              sTemp := sTemp + Copy(AList, 1, iStart);
              System.Delete(AList, 1, iStart);
            end;
          end;
        ':': {Do not Localize}
          begin
          // The start of a group - ignore the lot.
            System.Delete(AList, 1, iStart);
            sTemp := ''; {Do not Localize}
          end;
        ';': {Do not Localize}
          begin
          // End of a group.  If we have something (groups can be empty),
          // then process it.
            sTemp := sTemp + Copy(AList, 1, iStart - 1);
            if Trim(sTemp) <> '' then begin
              EMail := Add;
              EMail.Text := TrimLeft(sTemp);
              sTemp := ''; {Do not Localize}
            end;
          // Now simply remove the end of the group.
            System.Delete(AList, 1, iStart);
          end;
        '(': begin {Do not Localize}
            Inc(nInBracket);
            sTemp := sTemp + Copy(AList, 1, iStart);
            System.Delete(AList, 1, iStart);
          end;
        ')': begin {Do not Localize}
            Dec(nInBracket);
            sTemp := sTemp + Copy(AList, 1, iStart);
            System.Delete(AList, 1, iStart);
          end;
        '"': begin {Do not Localize}
            sTemp := sTemp + Copy(AList, 1, iStart);
            System.Delete(AList, 1, iStart);
            bInQuote := not bInQuote;
          end;
        ',': begin {Do not Localize}
            sTemp := sTemp + Copy(AList, 1, iStart - 1);
            EMail := Add;
            EMail.Text := sTemp;
          // added - Allen .. saves blank entries being added
            if (Trim(Email.Text) = '') or (Trim(Email.Text) = '<>') then {Do not Localize}
            begin
              FreeAndNil(Email);
            end;
            sTemp := ''; {Do not Localize}
            System.Delete(AList, 1, iStart);
          end;
        '\': begin {Do not Localize}
          // Escape character - simply copy this char and the next to the buffer.
            sTemp := sTemp + Copy(AList, 1, iStart + 1);
            System.Delete(AList, 1, iStart + 1);
          end;
      end;
 
      if nInBracket > 0 then begin
        iStart := FindFirstOf('(\)', AList); {Do not Localize}
      end else if bInQuote then begin
        iStart := FindFirstOf('"\', AList); {Do not Localize}
      end else begin
        iStart := FindFirstOf(':;(", ' + WideTab, AList); {Do not Localize}
      end;
    until iStart = 0;
 
    // Clean up the content in sTemp
    if (Trim(sTemp) <> '') or (Trim(AList) <> '') then begin
      sTemp := sTemp + AList;
      EMail := Add;
      EMail.Text := TrimLeft(sTemp);
      // added - Allen .. saves blank entries being added
      if (Trim(Email.Text) = '') or (Trim(Email.Text) = '<>') then {Do not Localize}
      begin
        FreeAndNil(Email);
      end;
    end;
  end;
end;
 
procedure TWideIdEMailAddressList.SortByDomain;
var
  i, j: Integer;
  LTemp: Widestring;
begin
  for i := Count - 1 downto 0 do
  begin
    for j := 0 to Count - 2 do
    begin
      if WideCompareStr(Items[J].Domain, Items[J + 1].Domain) > 0 then begin
        LTemp := Items[j].Text;
 
        Items[j].Text := Items[j + 1].Text;
        Items[j + 1].Text := LTemp;
      end;
    end;
  end;
end;
 
procedure TWideIdEMailAddressList.GetDomains(AStrings: TTntStrings);
var
  i: Integer;
  LCurDom: Widestring;
begin
  if Assigned(AStrings) then
  begin
    AStrings.Clear;
    for i := 0 to Count - 1 do
    begin
      LCurDom := Lowercase(Items[i].Domain);
      if AStrings.IndexOf(LCurDom) = -1 then
      begin
        AStrings.Add(LCurDom);
      end;
    end;
  end;
end;
 
procedure TWideIdEMailAddressList.AddressesByDomain(AList: TWideIdEMailAddressList;
  const ADomain: Widestring);
var
  i: Integer;
  LDomain: Widestring;
  LCurDom: Widestring;
  LEnt: TWideIdEMailAddressItem;
begin
  LDomain := LowerCase(ADomain);
  AList.Clear;
  for i := 0 to Count - 1 do
  begin
    LCurDom := LowerCase(Items[i].Domain);
    if LCurDom = LDomain then
    begin
      LEnt := AList.Add;
      LEnt.Text := Items[i].Text;
    end;
  end;
end;
 
end.