Looking for: HTML Editor or RTF to HTML conve...

Although using MSHTML as HTML editor could have been a good solution, I made something myself today: a TRichEdit to HTML converter. And I must say.. it perfectly suits my needs. It uses ComCtrls, Classes, SysUtils and Graphics so you'll have to put these into your uses clause to get this procedure to work.

The way this procedure works is basically different in that it doesn't convert raw RTF codes, but uses the RichEdit control to read the mark-up states needed to compose the HTML output. This method of converting a RichEdit's contents to HTML is everything but efficient... but it works which is something I cannot say about the other converters I tried!

If you have any comment on my solution, please tell me.

------------------------------------------------------------------------------------------------

procedure RichEditToHTML(ARichEdit: TRichEdit; AHTMLStrings: TStrings);

  function RtfFontSizeToHtmlFontSize(ARtfFontSize: Integer): Integer;
  begin
    case ARtfFontSize of
      0 .. 6 : Result := 0;
      7 .. 8 : Result := 1;
      9 ..10 : Result := 2;
      11..12 : Result := 3;
      13..14 : Result := 4;
      15..18 : Result := 5;
      19..24 : Result := 6;
    else
      Result := 7;
    end;
  end;

  function DelphiColorToWebColor(const AColor: TColor): string;
  var
    LHexColor: string;
  begin
    LHexColor := IntToHex(ColorToRGB(AColor), 6);
    Result := '#' + Copy(LHexColor, 5, 2) + Copy(LHexColor, 3, 2) + Copy(LHexColor, 1, 2);
  end;
 
  procedure AddTagsBeforeAndAfterEveryLine(ARichEdit: TRichEdit; ATextStrings: TStrings; var ABeforeTextTags, AAfterTextTags: TStrings);
  var
    LIterator: Integer;
    LBullets: Boolean;
    LDivTag: string;
  begin
    // Determine the tags before and after every line of text
    LBullets := false;
    for  LIterator := 0 to ATextStrings.Count - 1 do
    begin
      ARichEdit.SelStart := LongInt(ATextStrings.Objects[LIterator]);
      if ARichEdit.Paragraph.Alignment = taLeftJustify then
        LDivTag := '<DIV>'
      else if ARichEdit.Paragraph.Alignment = taCenter then
        LDivTag := '<DIV align="center">'
      else if ARichEdit.Paragraph.Alignment = taRightJustify then
        LDivTag := '<DIV align="right">';
      if ARichEdit.Paragraph.Numbering = nsBullet then
      begin
        if LBullets then
        begin
          ABeforeTextTags.Add('<LI>' + LDivTag);
          if LIterator < ATextStrings.Count - 1 then
            AAfterTextTags.Add('</DIV></LI>')
          else
            AAfterTextTags.Add('</DIV></LI></UL>');
        end
        else
        begin
          ABeforeTextTags.Add('<UL style="margin: 0px; padding: 0px 0px 0px 16px"><LI>' + LDivTag);
          if LIterator < ATextStrings.Count - 1 then
            AAfterTextTags.Add('</DIV></LI>')
          else
            AAfterTextTags.Add('</DIV></LI></UL>');
          LBullets := true;
        end;
      end
      else
      begin
        if LBullets then
        begin
          AAfterTextTags[LIterator - 1] := AAfterTextTags[LIterator - 1] + '</UL>';
          ABeforeTextTags.Add(LDivTag);
          AAfterTextTags.Add('</DIV>');
          LBullets := false;
        end
        else
        begin
          ABeforeTextTags.Add(LDivTag);
          AAfterTextTags.Add('</DIV>');
        end;
      end;
    end;
  end;

  procedure MergeThreeStringlists(var AStrings1, AStrings2, AStrings3, AMergedStrings: TStrings);
  var
    LIterator: Integer;
  begin
    if (AStrings1.Count <> AStrings2.Count) or (AStrings2.Count <> AStrings3.Count) then
      raise Exception.Create('Stringlists must be equal in length');
    if AStrings1.Count > 0 then
    begin
      for LIterator := 0 to AStrings1.Count - 1 do
        AMergedStrings.Add(AStrings1[LIterator] + AStrings2[LIterator] + AStrings3[LIterator]);
    end;
  end;

  procedure TextStringsToHTMLStrings(var ATextStrings: TStrings; ARichEdit: TRichEdit);

    function TagInAttributes(ATag: string; ARichEdit: TRichEdit): Boolean;
    begin
      if ATag = '<FONT face="' + ARichEdit.SelAttributes.Name + '" color="' + DelphiColorToWebColor(ARichEdit.SelAttributes.Color) + '" size=' + IntToStr(RtfFontSizeToHtmlFontSize(ARichEdit.SelAttributes.Size)) + '>' then
        Result := true
      else if ATag = '<B>' then
        Result := (fsBold in ARichEdit.SelAttributes.Style)
      else if ATag = '<I>' then
        Result := (fsItalic in ARichEdit.SelAttributes.Style)
      else if ATag = '<U>' then
        Result := (fsUnderline in ARichEdit.SelAttributes.Style)
      else if ATag = '<S>' then
        Result := (fsStrikeOut in ARichEdit.SelAttributes.Style)
      else
        Result := false;
    end;

    procedure OpenTag(ATag: string; var AHTMLString: string; var AOpenTags: TStrings);
    begin
      AHTMLString := AHTMLString + ATag;
      AOpenTags.Add(ATag);
    end;
   
    procedure CloseTag(ATag: string; var AHTMLString: string; var AOpenTags: TStrings);
    var
      LCloseTag: string;
    begin
      LCloseTag := '</' + Copy(ATag, 2, MaxInt);
      if pos(' ', LCloseTag) > 0 then
        Delete(LCloseTag, pos(' ', LCloseTag), Length(LCloseTag) - pos(' ', LCloseTag));
      AHTMLString := AHTMLString + LCloseTag;
      if AOpenTags.IndexOf(ATag) >= 0 then
        AOpenTags.Delete(AOpenTags.IndexOf(ATag));
    end;

  var
    LOpenTags: TStrings;
    LIterator1: Integer;
    LTextString: string;
    LHTMLString: string;
    LIterator2: Integer;
    LIterator3: Integer;
    LIterator4: Integer;
    LCurrentChar: Char;
  begin
    // Initialise the variables
    LOpenTags := TStringList.Create; try

    for LIterator1 := 0 to ATextStrings.Count - 1 do
    begin
   
      LTextString := ATextStrings[LIterator1];
      LHTMLString := '';
      LOpenTags.Clear;

      for LIterator2 := 1 to Length(LTextString) do
      begin

        // Read the current character
        LCurrentChar := LTextString[LIterator2];

        // Set the cursor to the current position so we can read the
        // textattributes and paraattributes of the current character
        ARichEdit.SelStart := LongInt(ATextStrings.Objects[LIterator1]) + LIterator2 - 1;

        // Close html tags
        // Determine till what level the tags can be kept open
        if LOpenTags.Count > 0 then
        begin
          // Initialize the counter for the level of tags we have to remain open
          LIterator3 := 0;

          // find out which tags may remain open
          while (LIterator3 < LOpenTags.Count) do
          begin
            if TagInAttributes(LOpenTags[LIterator3], ARichEdit) then
              Inc(LIterator3)
            else
              Break;
          end;

          // If there are tags that may not remain open... close them in reverse
          // order.
          if LIterator3 < LOpenTags.Count then
          begin
            for LIterator4 := LOpenTags.Count - 1 downto LIterator3 do
              CloseTag(LOpenTags[LIterator4], LHTMLString, LOpenTags);
          end;
        end;

        // Open html tags
        if LOpenTags.IndexOf('<FONT face="' + ARichEdit.SelAttributes.Name + '" color="' + DelphiColorToWebColor(ARichEdit.SelAttributes.Color) + '" size=' + IntToStr(RtfFontSizeToHtmlFontSize(ARichEdit.SelAttributes.Size)) + '>') = -1 then
          OpenTag('<FONT face="' + ARichEdit.SelAttributes.Name + '" color="' + DelphiColorToWebColor(ARichEdit.SelAttributes.Color) + '" size=' + IntToStr(RtfFontSizeToHtmlFontSize(ARichEdit.SelAttributes.Size)) + '>', LHTMLString, LOpenTags);
        if (fsBold in ARichEdit.SelAttributes.Style) then
          if LOpenTags.IndexOf('<B>') = -1 then
            OpenTag('<B>', LHTMLString, LOpenTags);
        if (fsItalic in ARichEdit.SelAttributes.Style) then
          if LOpenTags.IndexOf('<I>') = -1 then
            OpenTag('<I>', LHTMLString, LOpenTags);
        if (fsUnderline in ARichEdit.SelAttributes.Style) then
          if LOpenTags.IndexOf('<U>') = -1 then
            OpenTag('<U>', LHTMLString, LOpenTags);
        if (fsStrikeOut in ARichEdit.SelAttributes.Style) then
          if LOpenTags.IndexOf('<S>') = -1 then
            OpenTag('<S>', LHTMLString, LOpenTags);

        // Add currentchar
        if LCurrentChar = ' ' then
        begin
          if LIterator2 > 1 then
          begin
            if LTextString[LIterator2 - 1] = ' ' then
              LHTMLString := LHTMLString + ' '
            else
              LHTMLString := LHTMLString + LCurrentChar;
          end
          else
            LHTMLString := LHTMLString + LCurrentChar;
        end
        else if LCurrentChar = '"' then
          LHTMLString := LHTMLString + '"'
        else if LCurrentChar = '&' then
          LHTMLString := LHTMLString + '&'
        else if LCurrentChar = '<' then
          LHTMLString := LHTMLString + '<'
        else if LCurrentChar = '>' then
          LHTMLString := LHTMLString + '>'
        else
          LHTMLString := LHTMLString + LCurrentChar;
      end;

      // Close all tags in reverse order.
      if LOpenTags.Count > 0 then
      begin
        for LIterator3 := LOpenTags.Count - 1 downto 0 do
          CloseTag(LOpenTags[LIterator3], LHTMLString, LOpenTags);
      end;

      if Trim(LHTMLString) = '' then
        LHTMLString := LHTMLString + ' ';
       
      ATextStrings[LIterator1] := LHTMLString;

    end;

    finally LOpenTags.Free; end;
  end;

var
  LBeforeTextTags: TStrings;
  LTextStrings: TStrings;
  LAfterTextTags: TStrings;
begin
  LBeforeTextTags := TStringList.Create; try
  LTextStrings := TStringList.Create; try
  LAfterTextTags := TStringList.Create; try
  ARichEdit.Lines.BeginUpdate; try

  // Clear the output
  AHTMLStrings.Clear;

  // Split the text into separate strings and keep references to the
  // startposition of each line in the original textstring
  StringToStringListWithLineStartPointers(ARichEdit.Text, LTextStrings);

  // Continue conversion only if there is at least one line
  if LTextStrings.Count > 0 then
  begin

    // Add tags to open and close each line into the seperate
    // stringlists (LBeforeTextTags and LAfterTextTags).
    AddTagsBeforeAndAfterEveryLine(ARichEdit, LTextStrings, LBeforeTextTags, LAfterTextTags);

    TextStringsToHTMLStrings(LTextStrings, ARichEdit);

    // Open the HTML document:
    AHTMLStrings.Add('<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">');
    AHTMLStrings.Add('<HTML><HEAD><META http-equiv=Content-Type content="text/html; charset=utf-8"></HEAD><BODY>');

    // Merge the opentags, text and closetags into one stringlist (AHTMLStrings)
    MergeThreeStringlists(LBeforeTextTags, LTextStrings, LAfterTextTags, AHTMLStrings);

    // Close the HTML document:
    AHTMLStrings.Add('</BODY></HTML>');

  end;

  finally ARichEdit.Lines.EndUpdate; end;
  finally LAfterTextTags.Free; end;
  finally LTextStrings.Free; end;
  finally LBeforeTextTags.Free; end;
end;