procedure TForm1.MakeHtmlReply(ABody: TclTextBody; AHtml: TStrings);
const
  BLOCKQUOTEStart = '<BLOCKQUOTE + 
  style="PADDING-RIGHT: 0px; PADDING-LEFT: 5px; 
  MARGIN-LEFT: 5px; BORDER-LEFT: #000000 2px solid; MARGIN-RIGHT: 0px">';
  BLOCKQUOTEEnd = '</BLOCKQUOTE>';
var
  tag, tagEnd: TclHtmlTag;
  s, reply: string;
begin
  reply := '<DIV>Reply follows here</DIV>';
  s := ABody.Strings.Text;

  clHtmlParser1.Parse(s);

  tag := clHtmlParser1.Tags.TagByName('BODY');
  if(tag = nil) then
  begin
    s := reply + BLOCKQUOTEStart + s + BLOCKQUOTEEnd;
  end else
  begin
    Insert(reply + BLOCKQUOTEStart, s, tag.InnerTextPos);

    tagEnd := clHtmlParser1.Tags.TagByName('BODY', tag.NextTag);
    Insert(BLOCKQUOTEEnd, s, tagEnd.InnerTextPos + Length(reply + BLOCKQUOTEStart));
  end;

  AHtml.Text := s;
end;

procedure TForm1.MakeTextReply(ABody: TclTextBody; AText: TStrings);
var
  i: Integer;
begin
  AText.Add('Reply follows here');
  AText.Add('');
  AText.Add('');

  for i := 0 to ABody.Strings.Count - 1 do
  begin
    AText.Add('> ' + ABody.Strings[i]);
  end;
end;

function TForm1.GetMessageText(AHtml: TStrings): string;
begin
  FTextLines.Clear();
  clHtmlTextParser2.Parse(AHtml);
  Result := FTextLines.Text;
end;

procedure TForm1.clHtmlTextParser2ParseTag(Sender: TObject; ATag: TclHtmlTag);
begin
  if (ATag.IsText) then
    FTextLines.Add(ATag.Text);
end;

function TForm1.SendEmailMessage(const AToAddress, ASubject: string): Boolean;
var
  dlg: TMessageForm;
  text: string;
begin
  dlg := TMessageForm.Create(nil);
  try
    dlg.edtTo.Text := AToAddress;
    dlg.edtSubject.Text := ASubject;

    if (clMailMessage1.Html <> nil) then
    begin
      MakeHtmlReply(clMailMessage1.Html, dlg.memText.Lines);
    end else
    if (clMailMessage1.Text <> nil) then
    begin
      MakeTextReply(clMailMessage1.Text, dlg.memText.Lines);
    end;

    Result := (dlg.ShowModal() = mrOK);
    
    if Result then
    begin
      if (clMailMessage1.Html <> nil) then
      begin
        text := '';
        if (clMailMessage1.Text <> nil) then
        begin
          text := GetMessageText(dlg.memText.Lines);
        end;

        clMailMessage1.BuildMessage(text, dlg.memText.Lines.Text);
      end else
      begin
        clMailMessage1.BuildMessage(dlg.memText.Lines.Text, '');
      end;

      clMailMessage1.From.FullAddress := dlg.edtFrom.Text;
      clMailMessage1.ToList.EmailAddresses := dlg.edtTo.Text;
      clMailMessage1.Subject := dlg.edtSubject.Text;

      clSmtp1.Server := edtServerSmtp.Text;
      clSmtp1.Port := StrToInt(edtPortSmtp.Text);
      clSmtp1.UseTLS := ctAutomatic;
      clSmtp1.UserName := edtUser.Text;
      clSmtp1.Password := edtPassword.Text;

      clSmtp1.Open();

      try
        clSmtp1.Send(clMailMessage1);
      finally
        clSmtp1.Close();
      end;

    end;
  finally
    dlg.Free();
  end;
end;