clmailmessage.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

  
procedure RegisterBody(AMessageBodyClass: TclMessageBodyClass);
begin
  GetRegisteredBodyItems().Add(AMessageBodyClass);
  Classes.RegisterClass(AMessageBodyClass);
end;

function GetRegisteredBodyItems: TList;
begin
  if (RegisteredBodyItems = nil) then
  begin
    RegisteredBodyItems := TList.Create();
  end;
  Result := RegisteredBodyItems;
end;

function EmailListToString(AEmailList: TStrings): string;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to AEmailList.Count - 1 do
  begin
    Result := Result + ', ' + AEmailList[i];
  end;
  System.Delete(Result, 1, 2);
end;

procedure StringToEmailList(const AEmails: string; AEmailList: TStrings);
var
  StartPos, EndPos,
  Quote, i, Len: integer;
  s: string;
begin
  AEmailList.Clear();
  Quote := 0;
  i := 1;
  Len := Length(AEmails);
  while (i <= Len) do
  begin
    StartPos := i;
    EndPos := StartPos;
    while (i <= Len) do
    begin
      if (AEmails[i] in ['"', '''']) then
      begin
        Inc(Quote);
      end;
      if (AEmails[i] in [',', ';']) then
      begin
        if (Quote <> 1) then
        begin
          Break;
        end;
      end;
      Inc(EndPos);
      Inc(i);
    end;
    s := Trim(Copy(AEmails, StartPos, EndPos - StartPos));
    if Length(s) > 0 then
    begin
      AEmailList.Add(TrimLeft(s));
    end;
    i := EndPos + 1;
    Quote := 0;
  end;
end;

function EncodeField(const AFieldValue, ACharSet: string; ADefaultEncoding: TclEncodeMethod;
  ACharsPerLine: Integer): string;
const
  EncodingToName: array[TclEncodeMethod] of string = ('', 'Q', 'B', '', '');
var
  i: Integer;
  Strings: TStrings;
  Encoding: TclEncodeMethod;
  Encoder: TclEncoder;
  s: string;
begin
  Result := AFieldValue;
  if (Result = '') then Exit;

  if (ADefaultEncoding = cmUUEncode) then
  begin
    Result := TclCharSetTranslator.TranslateTo(ACharSet, AFieldValue);
  end else
  begin
    Encoder := TclEncoder.Create(nil);
    try
      Encoder.CharsPerLine := ACharsPerLine;
      Encoder.SuppressCrlf := False;

      Encoding := Encoder.GetNeedEncoding(AFieldValue);
      if (Encoding <> cmNone) and (ACharSet <> '') then
      begin
        Strings := TStringList.Create;
        try
          s := TclCharSetTranslator.TranslateTo(ACharSet, AFieldValue);
          Encoder.EncodeString(s, Result, Encoding);
          if (Encoding = cmMIMEQuotedPrintable) then
          begin
            Result := StringReplace(Result, #32, '_', [rfReplaceAll]);
          end;
          Strings.Text := Result;
          for i := 0 to Strings.Count - 1 do
          begin
            Strings[i] := Format('=?%s?%s?%s?=', [ACharSet, EncodingToName[Encoding], Strings[i]]);
          end;
          Result := Strings.Text;
          Result := Copy(Result, 1, Length(Result) - 2);
        finally
          Strings.Free();
        end;
      end;
    finally
      Encoder.Free();
    end;
  end;
end;

function DecodeField(const AFieldValue, ADefaultCharSet: string): string;
  function EncodingNameToType(const AEncodingName: string): TclEncodeMethod;
  begin
    Result := cmNone;
    if (AEncodingName = '') then Exit;
    case UpperCase(AEncodingName)[1] of
      'Q': Result := cmMIMEQuotedPrintable;
      'B': Result := cmMIMEBase64;
    end;
  end;

var
  Formatted, isUtf8: Boolean;
  EncodedBegin, FirstDelim,
  SecondDelim, EncodedEnd, TextBegin: Integer;
  Encoding: TclEncodeMethod;
  CurLine, ResString, s,
  EncodingName, CharsetName: String;
  Encoder: TclEncoder;
begin
  isUtf8 := False;
  Result := '';
  Encoder := TclEncoder.Create(nil);
  try
    Encoder.SuppressCrlf := False;
    Formatted := False;
    TextBegin := 1;
    CurLine := AFieldValue;
    EncodedBegin := Pos('=?', CurLine);
    while (EncodedBegin <> 0) do
    begin
      Result := Result + Copy(CurLine, TextBegin, EncodedBegin - TextBegin);
      TextBegin := EncodedBegin;
      FirstDelim := TextPos('?', CurLine, EncodedBegin + 2);
      if (FirstDelim <> 0) then
      begin
        SecondDelim := TextPos('?', CurLine, FirstDelim + 1);
        if ((SecondDelim - FirstDelim) = 2) then
        begin
          EncodedEnd := TextPos('?=', CurLine, SecondDelim + 1);
          if (EncodedEnd <> 0) then
          begin
            CharsetName := Copy(CurLine, EncodedBegin + 2, FirstDelim - 2 - EncodedBegin);
            EncodingName := CurLine[FirstDelim + 1];
            s := Copy(CurLine, SecondDelim + 1, EncodedEnd - SecondDelim - 1);
            try
              Encoding := EncodingNameToType(EncodingName);
              if Encoding = cmNone then
                raise EclMailMessageError.Create(cWrondEncodingMethod);
              Encoder.DecodeString(s, ResString, Encoding);

              if (Encoding = cmMIMEQuotedPrintable) then
              begin
                ResString := StringReplace(ResString, '_', #32, [rfReplaceAll]);
              end;

              isUtf8 := isUtf8 or SameText(CharsetName, 'utf-8');
              if not isUtf8 then
              begin
                s := TclCharSetTranslator.TranslateFrom(CharsetName, ResString);
              end else
              begin
                s := ResString;
              end;
              Result := Result + s;
              TextBegin := EncodedEnd + 2;
              Formatted := True;
            except
              TextBegin := EncodedBegin + 2;
              Result := Result + '=?';
            end;
            CurLine := Copy(CurLine, TextBegin, Length(CurLine));
            EncodedBegin := Pos('=?', CurLine);
            TextBegin := 1;
            Continue;
          end;
        end;
      end;
      EncodedBegin := 0;
      Result := Result + Copy(CurLine, TextBegin, Length(CurLine));
    end;
    if (not isUtf8) and (not Formatted) then
    begin
      Result := TclCharSetTranslator.TranslateFrom(ADefaultCharSet, AFieldValue);
    end;
  finally
    Encoder.Free();
  end;
end;

function EncodeEmail(const ACompleteEmail, ACharSet: string; ADefaultEncoding: TclEncodeMethod;
  ACharsPerLine: Integer): string;
var
  Name, EncodedName, Email: string;
begin
  if GetEmailAddressParts(ACompleteEmail, Name, Email) then
  begin
    EncodedName := EncodeField(Name, ACharSet, ADefaultEncoding, ACharsPerLine);
    Result := GetCompleteEmailAddress(EncodedName, Email);
  end else
  begin
    Result := ACompleteEmail;
  end;
end;

function DecodeEmail(const ACompleteEmail, ADefaultCharSet: string): string;
var
  AName, AEmail: string;
begin
  if GetEmailAddressParts(ACompleteEmail, AName, AEmail) then
  begin
    AName := DecodeField(AName, ADefaultCharSet);
    Result := GetCompleteEmailAddress(AName, AEmail);
  end else
  begin
    Result := ACompleteEmail;
  end;
end;

function GetCompleteEmailAddress(const AName, AEmail: string): string;
begin
  if (AName = '') or (AName = AEmail) then
  begin
    Result := AEmail;
  end else
  begin
    Result := Format('%s <%s>', [GetNormName(AName), AEmail]);
  end;
end;

function GetEmailAddressParts(const ACompleteEmail: string; var AName, AEmail: string): Boolean;
  function GetEmailAddressPartsByDelimiter(indStart: Integer; ADelimiterEnd: string): Boolean;
  var
    indEnd: Integer;
  begin
    AName := Trim(system.Copy(ACompleteEmail, 1, indStart - 1));
    indEnd := TextPos(ADelimiterEnd, ACompleteEmail, indStart + 1);
    Result := (indEnd > 0);
    if Result then
    begin
      AEmail := Trim(system.Copy(ACompleteEmail, indStart + 1, indEnd - indStart -1));
    end;
  end;

var
  indStart: Integer;
begin
  AName := ACompleteEmail;
  AEmail := ACompleteEmail;
  indStart := system.Pos('<', ACompleteEmail);
  Result := (indStart > 0);
  if Result then
  begin
    Result := GetEmailAddressPartsByDelimiter(indStart, '>');
  end else
  begin
    indStart := system.Pos('(', ACompleteEmail);
    Result := (indStart > 0);
    if Result then
    begin
      Result := GetEmailAddressPartsByDelimiter(indStart, ')');
    end;
  end;
  if Result then
  begin
    AName := Trim(GetDenormName(AName));
    if (Length(AName) > 1) and (AName[1] = '''') and (AName[Length(AName)] = '''') then
    begin
      AName := Copy(AName, 2, Length(AName) - 2);
    end;
  end;
end;

function DateTimeToMailTime(ADateTime: TDateTime): string;
var
  Year, Month, Day, Hour, Min, Sec, MSec: Word;
  DayName, MonthName: String;
begin
  DecodeDate(ADateTime, Year, Month, Day);
  DecodeTime(ADateTime, Hour, Min, Sec, MSec);
  DayName := cDays[DayOfWeek(ADateTime)];
  MonthName := cMonths[Month];
  Result := Format('%s, %d %s %d %d:%.2d:%.2d %s',
    [DayName, Day, MonthName, Year, Hour, Min, Sec, TimeZoneBiasString]);
end;

function MailTimeToDateTime(const ADateTimeStr: string): TDateTime;
  function ParseTime(const ASrc: string): TDateTime;
  var
    pm, am: Integer;
    src: string;
    h, m, s: Word;
  begin
    src := UpperCase(ASrc);
    pm := system.Pos('PM', src);
    am := system.Pos('AM', src);

    if (pm > 0) then
    begin
      src := system.Copy(src, 1, pm - 1);
    end;
    if (am > 0) then
    begin
      src := system.Copy(src, 1, am - 1);
    end;
    src := Trim(src);

    h := StrToIntDef(ExtractWord(1, src, [':']), 0);
    m := StrToIntDef(ExtractWord(2, src, [':']), 0);
    s := StrToIntDef(ExtractWord(3, src, [':']), 0);

    if (pm > 0) then
    begin
      if h < 12 then
      begin
        h := h + 12;
      end;
    end;
    if (am > 0) then
    begin
      if h = 12 then
      begin
        h := 0;
      end;
    end;
    Result := EncodeTime(h, m, s, 0);
  end;

  function GetCurrentMonth: Word;
  var
    yy, dd: Word;
  begin
    DecodeDate(Date(), yy, Result, dd);
  end;

var
  Year, Month, Day: Word;
  DayName, MonthName, YearName, TimeName, ZoneName: String;
  Time: TDateTime;
  DateTimeStr: String;
  P: Integer;
  s: string;
begin
  Result := 0.0;
  Time := 0.0;
  Year := 0;
  Month := 0;
  Day := 0;
  DateTimeStr := Trim(ADateTimeStr);
  P := Pos(',', DateTimeStr);
  if (P > 0) then
  begin
    system.Delete(DateTimeStr, 1, Succ(P));
  end;
  s := Trim(DateTimeStr);
  DateTimeStr := s;
  P := Pos(' ', DateTimeStr);
  if (P > 0) then
  begin
    DayName := Copy(DateTimeStr, 1, Pred(P));
    Day := StrToInt(DayName);
    system.Delete(DateTimeStr, 1, P);
  end;
  s := Trim(DateTimeStr);
  DateTimeStr := s;
  P := Pos(' ', DateTimeStr);
  if (P > 0) then
  begin
    MonthName := Copy(DateTimeStr, 1, Pred(P));
    Month := Succ(IndexOfStrArray(MonthName, cMonths));
    if (Month = 0) then
    begin
      Month := GetCurrentMonth();
    end else
    begin
      system.Delete(DateTimeStr, 1, P);
    end;
  end;
  s := Trim(DateTimeStr);
  DateTimeStr := s;
  P := Pos(' ', DateTimeStr);
  if (P > 0) then
  begin
    YearName := Copy(DateTimeStr, 1, Pred(P));
    Year := StrToInt(YearName);
    if (Year < 100) then
    begin
      if (Year > 10) then
        Year := Year + 1900
      else if (Year <= 10) then
        Year := Year + 2000;
    end;
    system.Delete(DateTimeStr, 1, P);
  end;
  s := Trim(DateTimeStr);
  DateTimeStr := s;
  P := Pos(' ', DateTimeStr);
  if (P > 0) then
  begin
    TimeName := Copy(DateTimeStr, 1, Pred(P));
    Time := ParseTime(TimeName);
    system.Delete(DateTimeStr, 1, P);
  end;
  if (Year > 0) and (Month > 0) and (Day > 0) then
  begin