Comment convertir un texte riche simple en balises HTML dans Delphi?

Après avoir essayé de nombreuses solutions différentes qui n'avaient pas donné des résultats précis, j'ai été inspiré par cette solution: Convert RTF en HTML et HTML vers RTF .

L'idée est que twebbrowser code> contrôle (dans la conception / Mode d'édition) Peut gérer et convertir un format de texte correctement riche lorsque celui-ci a été collé dans le presse-papiers. P>

uses SHDocVw, MSHTML;

function ClipboardToHTML(AParent: TWinControl): WideString;
var
  wb: TWebBrowser;

  function WaitDocumentReady: Boolean;
  var
    StartTime: DWORD;
  begin
    StartTime := GetTickCount;
    while wb.ReadyState <> READYSTATE_COMPLETE do
    begin
      Application.HandleMessage;
      if GetTickCount >= StartTime + 2000 then // time-out of max 2 sec
      begin
        Result := False; // time-out
        Exit;
      end;
    end;
    Result := True;
  end;
begin
  Result := '';
  wb := TWebBrowser.Create(nil);
  try
    wb.Silent := True;
    wb.Width := 0;
    wb.Height := 0;
    wb.Visible := False;
    TWinControl(wb).Parent := AParent;
    wb.HandleNeeded;
    if wb.HandleAllocated then
    begin
      wb.Navigate('about:blank');
      (wb.Document as IHTMLDocument2).designMode := 'on';
      if WaitDocumentReady then
      begin
        (wb.Document as IHTMLDocument2).execCommand('Paste', False, 0);
        Result := (wb.Document as IHTMLDocument2).body.innerHTML;
      end;
    end;
  finally
    wb.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  RichEdit1.SelectAll;
  RichEdit1.CopyToClipboard;

  ShowMessage(ClipboardToHTML(Self));
end;

Cela fonctionne vraiment bien pour moi. sans twebbrowser.

mais de HTML à richedit. p>

J'espère que quelqu'un trouverait utile. p>

        ////////////////////////////////////////////////////////
    //                                                    //
    //          Formatting Richedit with HTML tags        //
    //                    by Carbonize                    //
    //                                                    //
    //    This is my second Delphi project and another    //
    //    conversion of one of my Visual Basic codes.     //
    //                                                    //
    //    This code goes through a string looking for     //
    //    <xxx> style tags then formats the richedit      //
    //    according to the text in the tag. It does       //
    //    colours, italics, bold, underline, line breaks, //
    //    font face, and font size.                       //
    //                                                    //
    //    I made the original VB version as a way of      //
    //    formatting the help files in one of my programs //
    //    to make them look better and be easier to read. //
    //                                                    //
    //    Please remember I am new to Delphi so some      //
    //    of the code may be sloppy. When handling        //
    //    <Font tags I did it the long way so it could    //
    //    handle tags with spaces between the 'face' or   //
    //    'size' and the actual face/size such as         //
    //    <font name = "Comic Sans MS"> as some people    //
    //    do their HTML this way.                         //
    //                                                    //
    ////////////////////////////////////////////////////////
    //                                                    //
    //             Monday, 27th January 2003              //
    //                                                    //
    ////////////////////////////////////////////////////////



    unit Unit1;

    interface

    uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs, ComCtrls, StdCtrls;

    type
    TForm1 = class(TForm)
    txtHTML: TMemo;
    Button1: TButton;
    rchHTML: TRichEdit;
    procedure Button1Click(Sender: TObject);
    procedure DisplayText(Tag: string; Buf:string);
    procedure FontTags(Tag: string; Buf:string);
    private
    { Private declarations }
    public
    { Public declarations }
    end;

    var
    Form1: TForm1;

    implementation

    {$R *.dfm}

    procedure TForm1.Button1Click(Sender: TObject);
    var
            Buf : string;
            Bumf : string;
            tag : string;
    begin
    //Clear the Richedit and set default formatting
    rchHTML.text := '';
    rchHTML.SelAttributes.style := [];
    rchHTML.selattributes.color := clBlack;
    rchHTML.SelAttributes.Name := 'MS Sans Serif';
    rchHTML.SelAttributes.Size := 8;

    //strip all new line commands as it screws the code up.
    Bumf := stringreplace(txtHTML.Text, #13#10, '', [rfReplaceAll]);

    //if there's no '<' then there's no tags so display whole string.
    if pos('<', Bumf) = 0 then
    begin   //but first convert any <> replacement strings.
            Bumf := stringreplace(Bumf, '&lt;', '<', [rfReplaceAll]);
            Bumf := stringreplace(Bumf, '&gt;', '>', [rfReplaceAll]);
            Bumf := stringreplace(Bumf, '&amp;', '&', [rfReplaceAll]);
            rchHTML.SelText := Bumf;
            exit;
    end;

    //else thats display all text before the '<'.
    //But first convert any replacements that are in there.
    Buf := copy(Bumf, 0, pos('<', Bumf) - 1);
    Buf := stringreplace(Buf, '&lt;', '<', [rfReplaceAll]);
    Buf := stringreplace(Buf, '&gt;', '>', [rfReplaceAll]);
    Buf := stringreplace(Buf, '&amp;', '&', [rfReplaceAll]);
    rchHTML.SelText := Buf;

    //then strip all text before the '<'
    delete(Bumf, 1 ,pos('<', Bumf) - 1);

    //If there's no '>' then it's not a tag so just post it all
    If pos('>', Bumf) = 0 then
    begin
            rchHTML.SelText := Bumf;
            exit;
    end;

    //else we need to parse any and all tags and the strings to post
    While length(Bumf) > 0 do
    begin
    //the tag := all text between '<' and '>'
    Tag := copy(Bumf, 2, pos('>', Bumf) - 2);
    //the text we will post is everything after the '>'
    Buf := copy(Bumf, pos('>', Bumf) + 1, length(Bumf) - pos('>', Bumf));
    //Empty Bumf
    Bumf := '';
    //Are there any '<'s in the tag?
    while pos('<', tag) > 0 do
    begin  //if so then post all text before the'<' as it's not part of a tag
            rchhtml.SelText := '<' + copy(Tag, 1, pos('<', Tag) - 1);
            //tag then := all text from the '<'
            Tag := copy(Tag, pos('<', Tag) + 1, length(Tag) - pos('<', Tag));
    End;
    //if there's a '<' in Buf then there may be another Tag
    If pos('<', Buf) > 0 then
    begin   //So we make Bumf := everything after the '<'
            Bumf := copy(Buf, pos('<', Buf), (length(Buf) - pos('<', Buf)) + 1);
            //And buf := everything before it
            Buf := copy(Buf, 1, pos('<', Buf) - 1);
    end;
    //now we pass the tag and the buf text to our text formatting procedure
    DisplayText(Tag, Buf);
    end;

    end;

    procedure TForm1.DisplayText(Tag: string; Buf:string);
    begin
    //There is a problem where if buf = '' the richedit attributes didn't get set
    //so I included this shoddy fix.
    //If you know why this bug happens please let me know.
    If Buf = '' then Buf := #12;

    //in case we want to actually show a tag or the markers used for < and >
    Buf := stringreplace(Buf, '&lt;', '<', [rfReplaceAll]);
    Buf := stringreplace(Buf, '&gt;', '>', [rfReplaceAll]);
    Buf := stringreplace(Buf, '&amp;', '&', [rfReplaceAll]);
    Tag := stringreplace(Tag, '&lt;', '<', [rfReplaceAll]);
    Tag := stringreplace(Tag, '&gt;', '>', [rfReplaceAll]);
    Tag := stringreplace(Tag, '&amp;', '&', [rfReplaceAll]);

    //if it's a font tag then send it to font handling
    If copy(lowercase(Tag), 0, 5) = 'font ' then
    begin
    FontTags(Tag, Buf);
    exit;
    end;

    //go through all known tags, formatting richedit as appropriate
    if lowercase(Tag) = 'red' then
            rchHTML.SelAttributes.Color := clRed
    else if lowercase(Tag) = 'black' then
            rchHTML.SelAttributes.Color := clBlack
    else if lowercase(Tag) = 'blue' then
            rchHTML.SelAttributes.Color := clBlue
    else if lowercase(Tag) = 'cyan' then
            rchHTML.SelAttributes.Color := clAqua
    else if ((lowercase(Tag) = 'gray') or (lowercase(Tag) = 'grey')) then
            rchHTML.SelAttributes.Color := clGray
    else if lowercase(Tag) = 'green' then
            rchHTML.SelAttributes.Color := clGreen
    else if lowercase(Tag) = 'pink' then
            rchHTML.SelAttributes.Color := clFuchsia
    else if lowercase(Tag) = 'purple' then
            rchHTML.SelAttributes.Color := clPurple
    else if lowercase(Tag) = 'yellow' then
            rchHTML.SelAttributes.Color := clYellow
    else if lowercase(Tag) = 'b' then
            rchHTML.SelAttributes.Style := rchHTML.SelAttributes.Style + [fsBold]
    else if lowercase(Tag) = '/b' then
            rchHTML.SelAttributes.Style := rchHTML.SelAttributes.Style - [fsBold]
    else if lowercase(Tag) = 'i' then
            rchHTML.SelAttributes.Style := rchHTML.SelAttributes.Style + [fsItalic]
    else if lowercase(Tag) = '/i' then
            rchHTML.SelAttributes.Style := rchHTML.SelAttributes.Style - [fsItalic]
    else if lowercase(Tag) = 'u' then
            rchHTML.SelAttributes.Style := rchHTML.SelAttributes.Style + [fsUnderline]
    else if lowercase(Tag) = '/u' then
            rchHTML.SelAttributes.Style := rchHTML.SelAttributes.Style - [fsUnderline]
    else if lowercase(Tag) = 'br' then
            Buf := #13#10 + Buf        
    //If it's an unknown tag then display the tag
    else Buf := '<' + Tag + '>' + Buf;

    //Now we've set the attributes we can display the text.
    rchHTML.SelText := Buf;
    end;

    procedure TForm1.FontTags(Tag: string; Buf:string);
    var
            a: integer;
            tag2: String;
    begin
    //we know it's a font tag so strip the 'font '
    Delete(Tag, 1, 5);

    //lets see if the want to set the font face
    If pos('face', lowercase(Tag)) > 0 then
    begin   //get the position of 'face'
            a := pos('face', lowercase(Tag));
            //set our temporary string to := all text from 'face' to the end.
            tag2 := copy(Tag, a, length(Tag) - (a - 1));
            //Then get position of the opening".
            a := pos('"', Tag2) + 1;
            //set our temporary string to := all text from " + 1 to the end.
            Tag2 := copy(Tag2, a, length(Tag2) - (a - 1));
            //Then locate the closing "
            a := pos('"', Tag2) - 1;
            //then make tag2 = the text between " and "
            Tag2 := copy(Tag2, 1, a);
            //Now set the font name to the chosen one.
            rchHTML.SelAttributes.Name := Tag2;
    end;

    //Now check if they want to set the fonts size.
    If pos('size', lowercase(Tag)) > 0 then
    begin   //get the position of 'size'
            a := pos('size', lowercase(Tag));
            //Make temporary string := all text from 'size' to end of the tag
            tag2 := copy(Tag, a, length(Tag) - (a - 1));
            //get position of opening "
            a := pos('"', Tag2) + 1;
            //make tag2 := all text from " + 1 to the end.
            Tag2 := copy(Tag2, a, length(Tag2) - (a - 1));
            //get position of the closing "
            a := pos('"', Tag2) - 1;
            //make tag2 := text between " and "
            Tag2 := copy(Tag2, 1, a);
            //set the fonts size
            rchHTML.SelAttributes.Size := strtoint(Tag2);
    end;

    //Now we've formatted we can display the text.
    rchHTML.seltext := Buf;

    end;

    end.