that really works good for me. without TWebBrowser.
but from html to richedit.
hope someone find it useful.
////////////////////////////////////////////////////////
// //
// 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, '<', '<', [rfReplaceAll]);
Bumf := stringreplace(Bumf, '>', '>', [rfReplaceAll]);
Bumf := stringreplace(Bumf, '&', '&', [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, '<', '<', [rfReplaceAll]);
Buf := stringreplace(Buf, '>', '>', [rfReplaceAll]);
Buf := stringreplace(Buf, '&', '&', [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, '<', '<', [rfReplaceAll]);
Buf := stringreplace(Buf, '>', '>', [rfReplaceAll]);
Buf := stringreplace(Buf, '&', '&', [rfReplaceAll]);
Tag := stringreplace(Tag, '<', '<', [rfReplaceAll]);
Tag := stringreplace(Tag, '>', '>', [rfReplaceAll]);
Tag := stringreplace(Tag, '&', '&', [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.
