clmailmessage.pas

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

procedure TclMailMessage.SetCCList(const Value: TStrings);
begin
  FCCList.Assign(Value);
end;

procedure TclMailMessage.SetToList(const Value: TStrings);
begin
  FToList.Assign(Value);
end;

function TclMailMessage.GetIsMultiPartContent: Boolean;
begin
  Result := (Bodies.Count > 1) or (FIsParse and (FBoundary <> ''));
end;

procedure TclMailMessage.Clear;
begin
  BeginUpdate();
  try
    SetBoundary('');
    Subject := '';
    From := '';
    ToList.Clear();
    CCList.Clear();
    BCCList.Clear();
    Priority := mpNormal;
    Date := Now();
    Bodies.Clear();
    MessageFormat := mfNone;
    ContentType := cDefaultContentType;
    ContentSubType := '';
    MimeOLE := cMimeOLE;
    FMessageID := '';
    ReplyTo := '';
    References.Clear();
    NewsGroups.Clear();
    ExtraFields.Clear();
    ReadReceiptTo := '';
    ContentDisposition := '';
    RawHeader.Clear();
    FRawBodyStart := 0;

    CharSet := cDefaultCharSet;
    Encoding := cmNone;
  finally
    EndUpdate();
  end;
end;

procedure TclMailMessage.Changed;
begin
  FHeaderSource.Clear();
  FBodiesSource.Clear();
  FMessageSource.Clear();
  if Assigned(OnChanged) then
  begin
    OnChanged(Self);
  end;
end;

procedure TclMailMessage.SetCharSet(const Value: string);
begin
  if (FCharSet <> Value) then
  begin
    FCharSet := Value;
    Update();
  end;
end;

procedure TclMailMessage.SetDate(const Value: TDateTime);
begin
  if (FDate <> Value) then
  begin
    FDate := Value;
    Update();
  end;
end;

procedure TclMailMessage.SetEncoding(const Value: TclEncodeMethod);
begin
  if (FEncoding <> Value) then
  begin
    FEncoding := Value;
    Update();
  end;
end;

procedure TclMailMessage.SetFrom(const Value: string);
begin
  if (FFrom <> Value) then
  begin
    FFrom := Value;
    Update();
  end;
end;

procedure TclMailMessage.SetMessageFormat(const Value: TclMessageFormat);
begin
  if (FMessageFormat <> Value) then
  begin
    FMessageFormat := Value;
    Update();
  end;
end;

procedure TclMailMessage.SetPriority(const Value: TclMessagePriority);
begin
  if (FPriority <> Value) then
  begin
    FPriority := Value;
    Update();
  end;
end;

procedure TclMailMessage.SetSubject(const Value: string);
begin
  if (FSubject <> Value) then
  begin
    FSubject := Value;
    Update();
  end;
end;

procedure TclMailMessage.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TclMailMessage.EndUpdate;
begin
  if (FUpdateCount > 0) then
  begin
    Dec(FUpdateCount);
  end;
  Update();
end;

procedure TclMailMessage.Update;
begin
  if (not (csDestroying in ComponentState))
    and (not (csLoading in ComponentState))
    and (not (csDesigning in ComponentState))
    and (FUpdateCount = 0) then
  begin
    Changed();
  end;
end;

procedure TclMailMessage.DoGetDataStream(ABody: TclMessageBody;
  const AFileName: string; var AData: TStream; var Handled: Boolean);
begin
  if Assigned(OnGetDataStream) then
  begin
    OnGetDataStream(Self, ABody, AFileName, AData, Handled);
  end;
end;

procedure TclMailMessage.DoDataAdded(ABody: TclMessageBody; AData: TStream);
begin
  if Assigned(OnDataAdded) then
  begin
    OnDataAdded(Self, ABody, AData);
  end;
end;

procedure TclMailMessage.DoEncodingProgress(ABodyNo, ABytesProceed, ATotalBytes: Integer);
begin
  if Assigned(OnEncodingProgress) then
  begin
    OnEncodingProgress(Self, ABodyNo, ABytesProceed, ATotalBytes);
  end;
end;

procedure TclMailMessage.Loaded;
begin
  inherited Loaded();
  Update();
end;

procedure TclMailMessage.SetContentType(const Value: string);
begin
  if (FContentType <> Value) then
  begin
    FContentType := Value;
    Update();
  end;
end;

function TclMailMessage.GetHeaderSource: TStrings;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsMailMessageDemoDisplayed) and (not IsEncoderDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsMailMessageDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}
  if (FHeaderSource.Count = 0) then
  begin
    InternalAssignHeader(FHeaderSource);
  end;
  Result := FHeaderSource;
end;

procedure TclMailMessage.SetBoundary(const Value: string);
begin
  if (FBoundary <> Value) then
  begin
    FBoundary := Value;
    Update();
  end;
end;

procedure TclMailMessage.BuildImages(ABodies: TclMessageBodies; const AText, AHtml: string;
  AImages: TStrings);
var
  i: Integer;
  Multipart: TclMultipartBody;
  HtmlWithImages: string;
  ImageBody: TclImageBody;
begin
  Multipart := ABodies.AddMultipart();
  HtmlWithImages := AHtml;
  for i := 0 to AImages.Count - 1 do
  begin
    ImageBody := ABodies.AddImage(AImages[i]);
    HtmlWithImages := StringReplace(HtmlWithImages, ImageBody.FileName,
      'cid:' + ImageBody.ContentID, [rfReplaceAll, rfIgnoreCase]);
  end;
  Multipart.ContentType := BuildAlternative(Multipart.Bodies, AText, HtmlWithImages);
end;

procedure TclMailMessage.BuildAttachments(ABodies: TclMessageBodies; Attachments: TStrings);
var
  i: Integer;
begin
  for i := 0 to Attachments.Count - 1 do
  begin
    ABodies.AddAttachment(Attachments[i]);
  end;
end;

function TclMailMessage.BuildAlternative(ABodies: TclMessageBodies; const AText, AHtml: string): string;
begin
  Result := '';
  if (AText <> '') then
  begin
    ABodies.AddText(AText);
    Result := 'text/plain';
  end;
  if (AHtml <> '') then
  begin
    ABodies.AddHtml(AHtml);
    Result := 'text/html';
  end;
  if (ABodies.Count > 1) then
  begin
    Result := 'multipart/alternative';
  end;
end;

procedure TclMailMessage.BuildMessage(const AText, AHtml: string;
  AImages, Attachments: TStrings);
var
  Multipart: TclMultipartBody;
  TextSrc: string;
  dummyImg, dummyAttach: TStrings;
begin
  dummyImg := nil;
  dummyAttach := nil;
  try
    if (AImages = nil) then
    begin
      dummyImg := TStringList.Create();
      AImages := dummyImg;
    end;
    if (Attachments = nil) then
    begin
      dummyAttach := TStringList.Create();
      Attachments := dummyAttach;
    end;
    Assert((AText <> '') or (AHtml <> ''));
    if ((AImages.Count > 0) and (AText = '') and (AHtml <> '')) then
    begin
      TextSrc := #32;
    end else
    begin
      TextSrc := AText;
    end;
    Assert((AImages.Count = 0) or ((TextSrc <> '') and (AHtml <> '')));
    BeginUpdate();
    try
      SafeClear();
      if (AImages.Count = 0) and (Attachments.Count = 0) then
      begin
        ContentType := BuildAlternative(Bodies, TextSrc, AHtml);
      end else
      if (AImages.Count = 0) and (Attachments.Count > 0) then
      begin
        if (TextSrc <> '') and (AHtml <> '') then
        begin
          Multipart := Bodies.AddMultipart();
          Multipart.ContentType := BuildAlternative(Multipart.Bodies, TextSrc, AHtml);
        end else
        begin
          BuildAlternative(Bodies, TextSrc, AHtml);
        end;
        BuildAttachments(Bodies, Attachments);
        ContentType := 'multipart/mixed';
      end else
      if (AImages.Count > 0) and (Attachments.Count = 0) then
      begin
        BuildImages(Bodies, TextSrc, AHtml, AImages);
        ContentType := 'multipart/related';
        ContentSubType := 'multipart/alternative';
      end else
      if (AImages.Count > 0) and (Attachments.Count > 0) then
      begin
        Multipart := Bodies.AddMultipart();
        BuildImages(Multipart.Bodies, TextSrc, AHtml, AImages);
        Multipart.ContentType := 'multipart/related';
        Multipart.ContentSubType := 'multipart/alternative';
        BuildAttachments(Bodies, Attachments);
        ContentType := 'multipart/mixed';
      end else
      begin
        Assert(False);
      end;
    finally
      EndUpdate();
    end;
  finally
    dummyAttach.Free();
    dummyImg.Free();
  end;
end;

procedure TclMailMessage.SetContentSubType(const Value: string);
begin
  if (FContentSubType <> Value) then
  begin
    FContentSubType := Value;
    Update();
  end;
end;

procedure TclMailMessage.BuildMessage(const AText, AHtml: string);
begin
  BuildMessage(AText, AHtml, nil, nil);
end;

procedure TclMailMessage.BuildMessage(const AText: string;
  Attachments: TStrings);
begin
  BuildMessage(AText, '', nil, Attachments);
end;

function TclMailMessage.GetBodiesSource: TStrings;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsMailMessageDemoDisplayed) and (not IsEncoderDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsMailMessageDemoDisplayed := True;
    IsEncoderDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}
  if (FBodiesSource.Count = 0) then
  begin
    InternalAssignBodies(FBodiesSource);
  end;
  Result := FBodiesSource;
end;

function TclMailMessage.GetMessageSource: TStrings;
var
  lines: Integer;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsMailMessageDemoDisplayed) and (not IsEncoderDemoDisp