clmailmessage.pas

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

    ZoneName := DateTimeStr;
    Result := EncodeDate(Year, Month, Day);
    Result := Result + Time;
    Result := Result - TimeZoneBiasToDateTime(ZoneName);
    Result := GlobalTimeToLocalTime(Result);
  end;
end;

{ TclMessageBodies }

procedure TclMessageBodies.Add(AItem: TclMessageBody);
begin
  FList.Add(AItem);
  GetMailMessage().Update();
end;

function TclMessageBodies.AddAttachment(const AFileName: string): TclAttachmentBody;
begin
  Result := TclAttachmentBody.Create(Self);
  Result.FileName := AFileName;
end;

function TclMessageBodies.AddHtml(const AText: string): TclTextBody;
begin
  Result := AddText(AText);
  Result.ContentType := 'text/html';
end;

function TclMessageBodies.AddImage(const AFileName: string): TclImageBody;
begin
  Result := TclImageBody.Create(Self);
  Result.FileName := AFileName;
end;

function TclMessageBodies.AddItem(AItemClass: TclMessageBodyClass): TclMessageBody;
begin
  Result := AItemClass.Create(Self);
end;

function TclMessageBodies.AddMultipart: TclMultipartBody;
begin
  Result := TclMultipartBody.Create(Self);
end;

function TclMessageBodies.AddText(const AText: string): TclTextBody;
var
  encoder: TclEncoder;
begin
  Result := TclTextBody.Create(Self);
  Result.Strings.Text := AText;
  if (Result.Encoding = cmNone) then
  begin
    encoder := TclEncoder.Create(nil);
    try
      Result.Encoding := encoder.GetNeedEncoding(AText);
    finally
      encoder.Free();
    end;
  end;
end;

procedure TclMessageBodies.Assign(Source: TPersistent);
var
  i: Integer;
  Item: TclMessageBody;
begin
  if (Source is TclMessageBodies) then
  begin
    Clear();
    for i := 0 to TclMessageBodies(Source).Count - 1 do
    begin
      Item := TclMessageBodies(Source).Items[i];
      AddItem(TclMessageBodyClass(Item.ClassType)).Assign(Item);
    end;
  end else
  begin
    inherited Assign(Source);
  end;
end;

procedure TclMessageBodies.Clear;
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
  begin
    Items[i].Free();
  end;
  FList.Clear();
  GetMailMessage().Update();
end;

constructor TclMessageBodies.Create(AOwner: TclMailMessage);
begin
  inherited Create();
  Assert(AOwner <> nil);
  FOwner := AOwner;
  FList := TList.Create();
end;

procedure TclMessageBodies.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('Items', ReadData, WriteData, (FList.Count > 0));
end;

procedure TclMessageBodies.Delete(Index: Integer);
begin
  Items[Index].Free();
  FList.Delete(Index);
  GetMailMessage().Update();
end;

destructor TclMessageBodies.Destroy;
begin
  Clear();
  FList.Free();
  inherited Destroy();
end;

function TclMessageBodies.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TclMessageBodies.GetItem(Index: Integer): TclMessageBody;
begin
  Result := TclMessageBody(FList[Index]);
end;

function TclMessageBodies.GetMailMessage: TclMailMessage;
begin
  Result := FOwner;
end;

procedure TclMessageBodies.Move(CurIndex, NewIndex: Integer);
begin
  FList.Move(CurIndex, NewIndex);
  GetMailMessage().Update();
end;

procedure TclMessageBodies.ReadData(Reader: TReader);
var
  ItemClass: TclMessageBodyClass;
begin
  Clear();
  Reader.ReadListBegin();
  while not Reader.EndOfList() do
  begin
    ItemClass := TclMessageBodyClass(GetClass(Reader.ReadString()));
    if (ItemClass <> nil) then
    begin
      AddItem(ItemClass).ReadData(Reader);
    end;
  end;
  Reader.ReadListEnd();
end;

procedure TclMessageBodies.WriteData(Writer: TWriter);
var
  i: Integer;
begin
  Writer.WriteListBegin();
  for i := 0 to Count - 1 do
  begin
    Writer.WriteString(Items[i].ClassName);
    Items[i].WriteData(Writer);
  end;
  Writer.WriteListEnd();
end;

{ TclMailMessage }

procedure TclMailMessage.GenerateBoundary;
begin
  SetBoundary('Mark=_' + FloatToStr(Now()) + IntToStr(Random(1000)));
end;

procedure TclMailMessage.AssignContentType(ASource: TStrings);
var
  s: string;
begin
  if (MessageFormat = mfUUencode) then Exit;

  if IsMultiPartContent then
  begin
    s := Trim(ContentType);
    if (s = '') then
    begin
      s := 'multipart/mixed';
    end;
    if (ContentSubType <> '') then
    begin
      AddHeaderArrayField(ASource, [s, 'type="' + ContentSubType + '"',
        'boundary="' + Boundary + '"'], 'Content-Type', ';');
    end else
    begin
      AddHeaderArrayField(ASource, [s, 'boundary="' + Boundary + '"'], 'Content-Type', ';');
    end;
  end else
  begin
    s := Trim(ContentType);
    if (s = '') then
    begin
      s := 'text/plain';
    end;
    if (CharSet <> '') then
    begin
      AddHeaderArrayField(ASource, [s, 'charset="' + CharSet + '"'], 'Content-Type', ';');
    end else
    begin
      AddHeaderField(ASource, 'Content-Type', s);
    end;
  end;
end;

function TclMailMessage.BuildDelimitedField(AValues: TStrings; const ADelimiter: string): string;
var
  i: Integer;
  Comma: array[Boolean] of string;
begin
  Result := '';
  if (AValues.Count > 0) then
  begin
    Comma[False] := '';
    Comma[True] := ADelimiter;
    Result := Result + AValues[0] + Comma[AValues.Count > 1];
    for i := 1 to AValues.Count - 1 do
    begin
      Result := Result + AValues[i] + Comma[i < (AValues.Count - 1)];
    end;
  end;
end;

procedure TclMailMessage.InternalAssignHeader(ASource: TStrings);
  procedure AddEmailMultiField(ASource, AEmails: TStrings; const AName: string);
  var
    i: Integer;
    s: string;
  begin
    if (AEmails.Count > 0) then
    begin
      s := EncodeEmail(AEmails[0], CharSet, Encoding, CharsPerLine);
      for i := 1 to AEmails.Count - 1 do
      begin
        s := s + ','#13#10 + EncodeEmail(AEmails[i], CharSet, Encoding, CharsPerLine);
      end;
      AddHeaderField(ASource, AName, s);
    end;
  end;

begin
  GenerateBoundary();
  if IncludeRFC822Header then
  begin
    AddHeaderField(ASource, 'Message-ID', MessageID);
    AddHeaderField(ASource, 'From', EncodeEmail(From, CharSet, Encoding, CharsPerLine));
    AddHeaderField(ASource, 'Reply-To', EncodeEmail(ReplyTo, CharSet, Encoding, CharsPerLine));
    AddHeaderField(ASource, 'Newsgroups', BuildDelimitedField(NewsGroups, ','));
    AddHeaderField(ASource, 'References', BuildDelimitedField(References, #32));
    AddEmailMultiField(ASource, ToList, 'To');
    AddEmailMultiField(ASource, CCList, 'Cc');
    AddEmailMultiField(ASource, BCCList, 'Bcc');
    AddHeaderField(ASource, 'Subject', EncodeField(Subject, CharSet, Encoding, CharsPerLine));
    AddHeaderField(ASource, 'Date', EncodeField(DateTimeToMailTime(Self.Date), CharSet, Encoding, CharsPerLine));
    FLinesFieldPos := ASource.Count;
    if (MessageFormat <> mfUUencode) then
    begin
      AddHeaderField(ASource, 'MIME-Version', '1.0');
    end;
  end;

  AssignContentType(ASource);

  AddHeaderField(ASource, 'Content-Disposition', ContentDisposition);

  if not IsMultiPartContent then
  begin
    AddHeaderField(ASource, 'Content-Transfer-Encoding', EncodingMap[Encoding]);
  end;
  if IncludeRFC822Header then
  begin
    AddHeaderField(ASource, 'Importance', ImportanceMap[Priority]);
    AddHeaderField(ASource, 'X-Priority', PiorityMap[Priority]);
    if (MimeOLE <> '') then
    begin
      AddHeaderField(ASource, 'X-MSMail-Priority', MSPiorityMap[Priority]);
    end;
    AddHeaderField(ASource, 'X-MimeOLE', MimeOLE);

    AddHeaderField(ASource, 'Disposition-Notification-To', EncodeEmail(ReadReceiptTo, CharSet, Encoding, CharsPerLine));

    ASource.AddStrings(ExtraFields);
  end;
  ASource.Add('');
end;

function TclMailMessage.ParseAllHeaders(AStartFrom: Integer; ASource, AHeaders: TStrings): Integer;
var
  i: Integer;
begin
  Result := 0;
  AHeaders.Clear();
  for i := AStartFrom to ASource.Count - 1 do
  begin
    Result := i;
    if (ASource[i] = '') then Break;
    AHeaders.Add(ASource[i]);
  end;
end;

procedure TclMailMessage.ParseContentType(ASource, AFieldList: TStrings);
var
  s: string;
begin
  s := GetHeaderFieldValue(ASource, AFieldList, 'Content-Type');
  MessageFormat := ContentTypeMap[(s <> '') or (GetHeaderFieldValue(ASource, AFieldList, 'MIME-Version') <> '')];
  ContentType := GetHeaderFieldValueItem(s, '');
  ContentSubType := GetHeaderFieldValueItem(s, 'type=');
  SetBoundary(GetHeaderFieldValueItem(s, 'boundary='));
  CharSet := GetHeaderFieldValueItem(s, 'charset=');
end;

procedure TclMailMessage.InternalParseHeader(ASource: TStrings);
  procedure AssignPriority(const ASource, ALowLexem, AHighLexem: string);
  begin
    if (Priority <> mpNormal) or (ASource = '') then Exit;
    if (LowerCase(ASource) = LowerCase(ALowLexem)) then
    begin
      Priority := mpLow;
    end else
    if (LowerCase(ASource) = LowerCase(AHighLexem)) then
    begin
      Priority := mpHigh;
    end;
  end;

  procedure DecodeEmailList(AEmails: TStrings);
  var
    i: Integer;
  begin
    for i := 0 to AEmails.Count - 1 do
    begin
      AEmails[i] := DecodeEmail(AEmails[i], CharSet);
    end;
  end;

var
  s: string;
  FieldList: TStrings;
begin
  FIsParse := True;
  FieldList := nil;
  try
    FieldList := TStringList.Create();

    GetHeaderFieldList(0, ASource, FieldList);
    ParseContentType(ASource, FieldList);

    s := GetHeaderFieldValue(ASource, FieldList, 'Content-Disposition');
    ContentDisposition := GetHeaderFieldValueItem(s, '');

    s := LowerCase(GetHeaderFieldValue(ASource, FieldList, 'Content-Transfer-Encoding'));
    if (s = 'quoted-printable') then
    begin
      Encoding := cmMIMEQuotedPrintable;
    end else
    if (s = 'base64') then
    begin
      Encoding := cmMIMEBase64;
    end;
    From := DecodeEmail(GetHeaderFieldValue(ASource, FieldList, 'From'), CharSet);
    ToList.Text := StringReplace(GetHeaderFieldValue(ASource, FieldList, 'To'), ',', #13#10, [rfReplaceAll]);
    CCList.Text := StringReplace(GetHeaderFieldValue(ASource, FieldList, 'Cc'), ',', #13#10, [rfReplaceAll]);
    BCCList.Text := StringReplace(GetHeaderFieldValue(ASource, FieldList, 'Bcc'), ',', #13#10, [rfReplaceAll]);
    DecodeEmailList(ToList);
    DecodeEmailList(CCList);
    DecodeEmailList(BCCList);
    Subject := DecodeField(GetHeaderFieldValue(ASource, FieldList, 'Subject'), CharSet);
    try
      Self.Date := ParseDate(ASource, FieldList);
    except
    end;
    AssignPriority(GetHeaderFieldValue(ASource, FieldList, 'Importance'), 'Low', 'High');
    AssignPriority(GetHeaderFieldValue(ASource, FieldList, 'X-Priority'), '5', '1');
    AssignPriority(GetHeaderFieldValue(ASource, FieldList, 'X-MSMail-Priority'), 'Low', 'High');
    ReplyTo := DecodeEmail(GetHeaderFieldValue(ASource, FieldList, 'Reply-To'), CharSet);

    ReadReceiptTo := DecodeEmail(GetHeaderFieldValue(ASource, FieldList, 'Disposition-Notification-To'), CharSet);

    MessageID := GetHeaderFieldValue(ASource, FieldList, 'Message-ID');
    NewsGroups.Text := StringReplace(GetHeaderFieldValue(ASource, FieldList, 'Newsgroups'),
      ',', #13#10, [rfReplaceAll]);
    References.Text := StringReplace(GetHeaderFieldValue(ASource, FieldList, 'References'),
      #32, #13#10, [rfReplaceAll]);
    MimeOLE := GetHeaderFieldValue(ASource, FieldList, 'X-MimeOLE');

    FRawBodyStart := ParseAllHeaders(0, ASource, RawHeader) + 1;
    ParseExtraFields(RawHeader, FKnownFields, ExtraFields);
  finally
    FieldList.Free();
    FIsParse := False;
  end;
end;

procedure TclMailMessage.RegisterField(const AField: string);
begin
  if (FindInStrings(FKnownFields, AField) < 0) then
  begin
    FKnownFields.Add(AField);
  end;
end;

procedure TclMailMessage.RegisterFields;
begin
  RegisterField('Content-Type');
  RegisterField('Content-Disposition');
  RegisterField('Content-Transfer-Encoding');
  RegisterField('From');
  RegisterField('To');
  RegisterField('Cc');
  RegisterField('Bcc');
  RegisterField('Subject');
  RegisterField('Date');
  RegisterField('Importance');
  RegisterField('X-Priority');