unit uRichEditHtmlHelper;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics,
  Vcl.ComCtrls, Vcl.Buttons;

function HtmlToRichEdit(const AHtml: string; ARichEdit: TRichEdit): Boolean;
function RichEditToHtml(ARichEdit: TRichEdit): string;
procedure ToggleRichEditBold(ARichEdit: TRichEdit; ABtnBold: TSpeedButton = nil);
procedure ToggleRichEditUnderline(ARichEdit: TRichEdit; ABtnUnderline: TSpeedButton = nil);
procedure UpdateRichEditToolbar(ARichEdit: TRichEdit; ABtnBold: TSpeedButton; ABtnUnderline: TSpeedButton);
procedure ToggleRichEditSourceView(ARichEdit: TRichEdit; ABtnSource: TSpeedButton);
function GetRichEditHtml(ARichEdit: TRichEdit; ABtnSource: TSpeedButton = nil): string;
procedure LoadRichEditHtml(const AHtml: string; ARichEdit: TRichEdit; ABtnSource: TSpeedButton = nil);

implementation

procedure ToggleRichEditBold(ARichEdit: TRichEdit; ABtnBold: TSpeedButton = nil);
begin
  if not Assigned(ARichEdit) then Exit;
  if fsBold in ARichEdit.SelAttributes.Style then
    ARichEdit.SelAttributes.Style := ARichEdit.SelAttributes.Style - [fsBold]
  else
    ARichEdit.SelAttributes.Style := ARichEdit.SelAttributes.Style + [fsBold];

  if Assigned(ABtnBold) then
    ABtnBold.Down := fsBold in ARichEdit.SelAttributes.Style;
  ARichEdit.SetFocus;
end;

procedure ToggleRichEditUnderline(ARichEdit: TRichEdit; ABtnUnderline: TSpeedButton = nil);
begin
  if not Assigned(ARichEdit) then Exit;
  if fsUnderline in ARichEdit.SelAttributes.Style then
    ARichEdit.SelAttributes.Style := ARichEdit.SelAttributes.Style - [fsUnderline]
  else
    ARichEdit.SelAttributes.Style := ARichEdit.SelAttributes.Style + [fsUnderline];

  if Assigned(ABtnUnderline) then
    ABtnUnderline.Down := fsUnderline in ARichEdit.SelAttributes.Style;
  ARichEdit.SetFocus;
end;

procedure UpdateRichEditToolbar(ARichEdit: TRichEdit; ABtnBold: TSpeedButton; ABtnUnderline: TSpeedButton);
begin
  if not Assigned(ARichEdit) then Exit;
  if Assigned(ABtnBold) then
    ABtnBold.Down := fsBold in ARichEdit.SelAttributes.Style;
  if Assigned(ABtnUnderline) then
    ABtnUnderline.Down := fsUnderline in ARichEdit.SelAttributes.Style;
end;

function HtmlToRichEdit(const AHtml: string; ARichEdit: TRichEdit): Boolean;
var
  i, Len, TagStart, TagEnd: Integer;
  TagContent, UpperTag: string;
  CurText: string;
  IsBold, IsUnderline: Boolean;
  CurSize, BaseSize: Integer;
  SizeVal: Integer;

  procedure FlushCurrentChunk;
  var
    StartPos: Integer;
  begin
    if CurText <> '' then
    begin
      StartPos := ARichEdit.GetTextLen;
      ARichEdit.SelStart := StartPos;
      ARichEdit.SelLength := 0;
      ARichEdit.SelAttributes.Style := [];
      if IsBold then
        ARichEdit.SelAttributes.Style := ARichEdit.SelAttributes.Style + [fsBold];
      if IsUnderline then
        ARichEdit.SelAttributes.Style := ARichEdit.SelAttributes.Style + [fsUnderline];
      ARichEdit.SelAttributes.Size := CurSize;
      ARichEdit.SelText := CurText;
      CurText := '';
    end;
  end;

begin
  Result := True;
  if not Assigned(ARichEdit) then Exit(False);

  ARichEdit.Lines.BeginUpdate;
  try
    ARichEdit.Clear;
    BaseSize := ARichEdit.Font.Size;
    if BaseSize <= 0 then BaseSize := 10;
    CurSize := BaseSize;
    IsBold := False;
    IsUnderline := False;
    CurText := '';

    i := 1;
    Len := Length(AHtml);
    while i <= Len do
    begin
      if AHtml[i] = '<' then
      begin
        TagStart := i;
        TagEnd := Pos('>', Copy(AHtml, TagStart, Len - TagStart + 1));
        if TagEnd > 0 then
        begin
          TagEnd := TagStart + TagEnd - 1;
          TagContent := Trim(Copy(AHtml, TagStart + 1, TagEnd - TagStart - 1));
          UpperTag := UpperCase(TagContent);

          FlushCurrentChunk;

          if (UpperTag = 'B') or (UpperTag = 'STRONG') then
            IsBold := True
          else if (UpperTag = '/B') or (UpperTag = '/STRONG') then
            IsBold := False
          else if UpperTag = 'U' then
            IsUnderline := True
          else if UpperTag = '/U' then
            IsUnderline := False
          else if Pos('FONT', UpperTag) = 1 then
          begin
            var LSizePos := Pos('SIZE=', UpperTag);
            if LSizePos > 0 then
            begin
              var LValStr := Copy(TagContent, LSizePos + 5, Length(TagContent));
              LValStr := StringReplace(LValStr, '"', '', [rfReplaceAll]);
              LValStr := StringReplace(LValStr, '''', '', [rfReplaceAll]);
              LValStr := Trim(LValStr);
              var LSpacePos := Pos(' ', LValStr);
              if LSpacePos > 0 then
                LValStr := Copy(LValStr, 1, LSpacePos - 1);
              SizeVal := StrToIntDef(LValStr, BaseSize);
              if SizeVal > 0 then
                CurSize := SizeVal;
            end;
          end
          else if UpperTag = '/FONT' then
            CurSize := BaseSize
          else if (UpperTag = 'BR') or (UpperTag = 'BR/') or (UpperTag = 'BR /') then
            CurText := CurText + sLineBreak;

          i := TagEnd + 1;
          Continue;
        end
        else
        begin
          // Tag HTML truncado al final de la cadena: ignorar residuo para no mostrar '<' suelto
          Break;
        end;
      end;

      if AHtml[i] = '&' then
      begin
        var SemiPos := Pos(';', Copy(AHtml, i, 12));
        if SemiPos > 1 then
        begin
          var Entity := Copy(AHtml, i, SemiPos);
          var DecodedChar: string := '';

          if Entity = '&lt;' then DecodedChar := '<'
          else if Entity = '&gt;' then DecodedChar := '>'
          else if Entity = '&amp;' then DecodedChar := '&'
          else if Entity = '&quot;' then DecodedChar := '"'
          else if (Entity = '&apos;') or (Entity = '&#39;') then DecodedChar := ''''
          else if Entity = '&nbsp;' then DecodedChar := ' '
          else if (Entity = '&aacute;') or (Entity = '&#225;') then DecodedChar := 'á'
          else if (Entity = '&eacute;') or (Entity = '&#233;') then DecodedChar := 'é'
          else if (Entity = '&iacute;') or (Entity = '&#237;') then DecodedChar := 'í'
          else if (Entity = '&oacute;') or (Entity = '&#243;') then DecodedChar := 'ó'
          else if (Entity = '&uacute;') or (Entity = '&#250;') then DecodedChar := 'ú'
          else if (Entity = '&ntilde;') or (Entity = '&#241;') then DecodedChar := 'ñ'
          else if (Entity = '&uuml;') or (Entity = '&#252;') then DecodedChar := 'ü'
          else if (Entity = '&Aacute;') or (Entity = '&#193;') then DecodedChar := 'Á'
          else if (Entity = '&Eacute;') or (Entity = '&#201;') then DecodedChar := 'É'
          else if (Entity = '&Iacute;') or (Entity = '&#205;') then DecodedChar := 'Í'
          else if (Entity = '&Oacute;') or (Entity = '&#211;') then DecodedChar := 'Ó'
          else if (Entity = '&Uacute;') or (Entity = '&#218;') then DecodedChar := 'Ú'
          else if (Entity = '&Ntilde;') or (Entity = '&#209;') then DecodedChar := 'Ñ'
          else if (Entity = '&Uuml;') or (Entity = '&#220;') then DecodedChar := 'Ü'
          else if (Entity = '&ordf;') or (Entity = '&#170;') then DecodedChar := 'ª'
          else if (Entity = '&ordm;') or (Entity = '&#186;') then DecodedChar := 'º'
          else if (Entity = '&bull;') or (Entity = '&#8226;') then DecodedChar := '•'
          else if (Entity = '&euro;') or (Entity = '&#8364;') then DecodedChar := '€'
          else if (Length(Entity) > 3) and (Entity[2] = '#') then
          begin
            var LNumStr := Copy(Entity, 3, Length(Entity) - 3);
            var LCode: Integer;
            if (Length(LNumStr) > 1) and ((LNumStr[1] = 'x') or (LNumStr[1] = 'X')) then
              LCode := StrToIntDef('$' + Copy(LNumStr, 2, Length(LNumStr)), 0)
            else
              LCode := StrToIntDef(LNumStr, 0);
            if (LCode > 0) and (LCode <= 65535) then
              DecodedChar := Chr(LCode);
          end;

          if DecodedChar <> '' then
          begin
            CurText := CurText + DecodedChar;
            Inc(i, Length(Entity));
            Continue;
          end;
        end;
      end;

      CurText := CurText + AHtml[i];
      Inc(i);
    end;
    FlushCurrentChunk;
    ARichEdit.SelStart := 0;
    ARichEdit.SelLength := 0;
  finally
    ARichEdit.Lines.EndUpdate;
  end;
end;

function RichEditToHtml(ARichEdit: TRichEdit): string;
var
  LRes: TStringBuilder;
  LCharBold, LCharUnderline: Boolean;
  LCharSize, LBaseSize: Integer;
  CurBold, CurUnderline: Boolean;
  CurSize: Integer;
  Ch: Char;

  procedure CloseTags;
  begin
    if CurUnderline then
    begin
      LRes.Append('</u>');
      CurUnderline := False;
    end;
    if CurBold then
    begin
      LRes.Append('</b>');
      CurBold := False;
    end;
    if (CurSize > 0) and (CurSize <> LBaseSize) then
    begin
      LRes.Append('</font>');
      CurSize := LBaseSize;
    end;
  end;

  procedure OpenTags(ABold, AUnderline: Boolean; ASize: Integer);
  begin
    if (ASize > 0) and (ASize <> LBaseSize) then
    begin
      LRes.Append('<font size="');
      LRes.Append(IntToStr(ASize));
      LRes.Append('">');
      CurSize := ASize;
    end;
    if ABold then
    begin
      LRes.Append('<b>');
      CurBold := True;
    end;
    if AUnderline then
    begin
      LRes.Append('<u>');
      CurUnderline := True;
    end;
  end;

var
  LPrevSelStart, LPrevSelLen: Integer;
  LText: string;
  LCharPos, i, LLen: Integer;
begin
  if not Assigned(ARichEdit) or (Trim(ARichEdit.Text) = '') then
    Exit('');

  LRes := TStringBuilder.Create;
  LPrevSelStart := ARichEdit.SelStart;
  LPrevSelLen := ARichEdit.SelLength;
  ARichEdit.Lines.BeginUpdate;
  try
    LBaseSize := ARichEdit.Font.Size;
    if LBaseSize <= 0 then LBaseSize := 10;

    CurBold := False;
    CurUnderline := False;
    CurSize := LBaseSize;

    LText := ARichEdit.Text;
    LLen := Length(LText);
    LCharPos := 0;
    i := 1;

    while i <= LLen do
    begin
      Ch := LText[i];
      if Ch = #13 then
      begin
        CloseTags;
        LRes.Append('<br>');
        Inc(LCharPos);
        if (i < LLen) and (LText[i + 1] = #10) then
          Inc(i);
        Inc(i);
        Continue;
      end
      else if Ch = #10 then
      begin
        Inc(i);
        Continue;
      end;

      ARichEdit.SelStart := LCharPos;
      ARichEdit.SelLength := 1;
      Inc(LCharPos);

      LCharBold := fsBold in ARichEdit.SelAttributes.Style;
      LCharUnderline := fsUnderline in ARichEdit.SelAttributes.Style;
      LCharSize := ARichEdit.SelAttributes.Size;
      if LCharSize <= 0 then LCharSize := LBaseSize;

      if (LCharBold <> CurBold) or (LCharUnderline <> CurUnderline) or (LCharSize <> CurSize) then
      begin
        CloseTags;
        OpenTags(LCharBold, LCharUnderline, LCharSize);
      end;

      case Ch of
        '<': LRes.Append('&lt;');
        '>': LRes.Append('&gt;');
        '&': LRes.Append('&amp;');
        '"': LRes.Append('&quot;');
      else
        if (Ord(Ch) >= 32) or (Ch = #9) then
          LRes.Append(Ch);
      end;
      Inc(i);
    end;

    CloseTags;
    Result := LRes.ToString;
  finally
    LRes.Free;
    ARichEdit.SelStart := LPrevSelStart;
    ARichEdit.SelLength := LPrevSelLen;
    ARichEdit.Lines.EndUpdate;
  end;
end;

procedure ToggleRichEditSourceView(ARichEdit: TRichEdit; ABtnSource: TSpeedButton);
var
  LHtml: string;
begin
  if not Assigned(ARichEdit) or not Assigned(ABtnSource) then Exit;

  if ABtnSource.Down then
  begin
    // Cambiar a modo código fuente / caracteres ocultos (muestra el HTML crudo con todos los tags)
    LHtml := RichEditToHtml(ARichEdit);
    ARichEdit.Lines.BeginUpdate;
    try
      ARichEdit.Clear;
      ARichEdit.Font.Name := 'Consolas';
      ARichEdit.Font.Size := 9;
      ARichEdit.Font.Color := clWindowText;
      ARichEdit.Font.Style := [];
      ARichEdit.Lines.Text := LHtml;
      ARichEdit.SelStart := 0;
      ARichEdit.SelLength := 0;
    finally
      ARichEdit.Lines.EndUpdate;
    end;
    ABtnSource.Hint := 'Volver a modo visual enriquecido';
  end
  else
  begin
    // Cambiar de modo código a modo visual (renderiza el formato WYSIWYG)
    LHtml := ARichEdit.Lines.Text;
    ARichEdit.Font.Name := 'Segoe UI';
    ARichEdit.Font.Size := 9;
    ARichEdit.Font.Color := clWindowText;
    ARichEdit.Font.Style := [];
    HtmlToRichEdit(LHtml, ARichEdit);
    ABtnSource.Hint := 'Ver código HTML y caracteres ocultos';
  end;
  ARichEdit.SetFocus;
end;

function GetRichEditHtml(ARichEdit: TRichEdit; ABtnSource: TSpeedButton = nil): string;
begin
  if not Assigned(ARichEdit) then Exit('');
  if Assigned(ABtnSource) and ABtnSource.Down then
    Result := ARichEdit.Lines.Text
  else
    Result := RichEditToHtml(ARichEdit);
end;

procedure LoadRichEditHtml(const AHtml: string; ARichEdit: TRichEdit; ABtnSource: TSpeedButton = nil);
begin
  if not Assigned(ARichEdit) then Exit;
  if Assigned(ABtnSource) and ABtnSource.Down then
  begin
    ARichEdit.Lines.BeginUpdate;
    try
      ARichEdit.Clear;
      ARichEdit.Font.Name := 'Consolas';
      ARichEdit.Font.Size := 9;
      ARichEdit.Font.Color := clWindowText;
      ARichEdit.Font.Style := [];
      ARichEdit.Lines.Text := AHtml;
      ARichEdit.SelStart := 0;
      ARichEdit.SelLength := 0;
    finally
      ARichEdit.Lines.EndUpdate;
    end;
  end
  else
  begin
    ARichEdit.Font.Name := 'Segoe UI';
    ARichEdit.Font.Size := 9;
    ARichEdit.Font.Color := clWindowText;
    ARichEdit.Font.Style := [];
    HtmlToRichEdit(AHtml, ARichEdit);
  end;
end;

end.