Array
(
)

RichEdit para HTML

Vetorzero
   - 16 ago 2004

Companheiros programadores,

Desenvolvi um formulário para envio de e-mail. Uso o componente TRichEdit para escrever e formatar o texto. Através deste formulário posso editar o texto com diversas características: seleção de fonte, cor de fonte, negrito, sublinhado, alinhamento, cor de fundo, inserção de imagens...
Quando envio a mensagem (Componete SMSMTP) o envio é processado normalmente so que o destinatário recebe a mensagem sem nenhuma formatação.

Vocês conhecem algum componente (ou desenvolveram alguma rotina) que transforma o texto digitado e formatado no RichEdit para HTML ?

É isso. Obrigado pela atenção.


Motta
   - 16 ago 2004

tenho um , comentarios em alemão, sequer sei se é de uso público, se quiser te envio por email.


Vetorzero
   - 16 ago 2004

Motta,

Quero sim e fico muito agradecido. Preciso resolver esse problema o quanto antes.

Valeu.


Kenshindigital
   - 17 ago 2004

eu até que precisava de um também, acho que já vi uma rotina chamada rtf2sgml vi la no UDDF só que ela não funcionou direito...


Motta
   - 17 ago 2004

Se alguem le alemão (creio que seja alemão) pode traduzir os comentarios ...

Não sei se o uso é livre.

[tagcod]
unit r2hconv;

interface


uses Classes, SysUtils, Mdfuncs;


const { Pseudo-enum für Tabellen-Behandlung }
plain : integer = 0;
in_cell : integer = 1;
cell_end : integer = 2;
row_end : integer = 3;


fontsOpt : integer = 3; { Die ersten <fontsOpt> Schriftarten in der font table werden bei Redundanz }
{ im HTML-Code wegoptimiert (sofern Flag ´optimize´ gesetzt ist) }

ul_indent : integer = 285; { left indent wird in (left indent DIV ul_indent) <UL>s umgewandelt }
{ je kleiner dieser Wert ist, desto feiner sind die Level-Unterteilungen, }
{ aber es werden auch umso mehr <UL>s pro Einzug generiert }

type formata = record
invis : boolean; { versteckter Text }
caps : boolean; { Blockschrift }
bold : boolean; { fett }
italic : boolean; { kursiv }
underline : boolean; { unterstrichen }
superscript : boolean; { hochgestellt }
subscript : boolean; { tiefgestellt }
strike : boolean; { durchgestrichen }
font : integer; { Schriftart }
fcol : string; { Text-Fabe }
fsize : integer; { Text-Größe }
rjustified : boolean; { rechtsbündig }
centered : boolean; { zentriert }
table : integer; { Tabelle }
end;

type font = record
name : string;
number : integer;
end;

type
stackptr = ^stackelem; { der Formatierungs-Stack }
stackelem = record
tagstart : string;
tagend : string;
next : stackptr;
end;

type
strlptr = ^slelem;
slelem = record
lstring : string;
next : strlptr;
end;

type enumlist = record
doclvl : integer;
lvl : integer;
indent : array[0..20] of integer;
end;

type ss = record
name : string;
ctrl : string;
end;

type flags = record
noFonts : boolean;
optimize : boolean;
onlyDefiniteOpt : boolean;
end;

var
flag : flags;
stylesheet : array [0..300] of ss;
killstr : strlptr;
col : TStringList;
fonts : array[0..200] of font;
linkstyles, anchstyles, actlinknum, actanchnum : array [1..9] of integer;

outstring, pntxta, pntxtb, enumtxt, txtwait : string;
invis, bkmkpar, lastline, li_open, listitem, listbull, pnnum, nextpar, enumdigit : boolean;
ahref, anchor, ahrefwait, newhrefnum, no_newind : boolean;

changefmt : boolean;
mainstack : stackptr;

anchlvl, indexlvl, lastindent, lvlnum, globbrk : integer;

enums : enumlist;


procedure rtf2html (filename: string; destfilename: string; param: array of string;imag:string;assunto:string);
//Raquel - incluí os parâmetros imag e assunto para passar a imagem e o assunto da mensagem

implementation

{ ************************************************************************ }
{ }
{ RTF2HTML V 2.1 }
{ by hr }
{ last change: 15-07-98 }
{ }
{ Diese Version sollte weniger komplexe RTF-Files fehlerfrei bzw. }
{ komplexere RTF-Files layoutmäßig weitestgehend korrekt übersetzen können }
{ }
{ Aufruf-Parameter: }
{ }
{ - ´optimize´ }
{ eliminiert überflüssige HTML-Tags wie zb. ´<B></B>´ oder </SUB><SUB> }
{ - ´onlyDefiniteOpt´ }
{ sorgt dafür, das Strings wie ´</FONT><FONT FACE="Arial">´ NICHT }
{ wegoptimiert werden, da das schließende </FONT>-Tag u.u. eine andere }
{ Anweisung als <FONT FACE="Arial"> hier im Beispiel deaktivieren }
{ könnte }
{ - ´noFonts´ }
{ deaktiviert alle <FONT FACE="...">-Anweisungen }
{ }
{ Folgendes wird, so weit im HTML 3 möglich, äquivalent übersetzt: }
{ }
{ - Stylesheets im allgemeinen (fließt in die spezifischen Zeilen- }
{ Formatierungen mit ein) }
{ - bold, italic, underline, strikethrough, subscript, superscript }
{ - center, left/right justified }
{ - Aufzählungen aller Arten }
{ - left indents (mittels <UL>-Schachtelungen) }
{ - Zeilenumbruch/Absatz }
{ - etwaige Farb-/Schriftart-/Schriftgröße-Formatierungen }
{ - Sonderzeichen ( ´ " < usw.) }
{ - Tabellen }
{ }
{ Folgendes kann Fehler bzw. unerwünschte Ergebnisse verursachen }
{ (known ´bugs´): }
{ }
{ - Der Aufrufparameter ´optimize´ bewirkt, daß auch Zeichenketten wie }
{ ´</FONT><FONT FACE="Arial">´ gnadenlos wegoptimiert werden kann, was }
{ leicht in Formatierungs-Fehlern (NICHT HTML-Syntax-Fehlern) enden }
{ kann; Abhilfe: Parameter ´onlyDefiniteOpt´ }
{ - Übernahme von Text-Formatierungen in eine Tabelle, wenn eine solche }
{ beginnt, was in RTF rein theoretisch möglich ist, findet NICHT statt }
{ GRUND: 1. werden beim Beginn einer Tabelle normalerweise ohnehin }
{ alle Text-Formatierungen zurückgesetzt }
{ 2. müßte man eine ´mitgeschleifte´ Formatierung in einer }
{ HTML-Tabelle Feld für Feld neu setzen und am Feld-Ende }
{ wieder löschen ---> das ausgespuckte HTML-File wird }
{ **SEHR** groß }
{ - Aufzählungen in Tabellenfeldern (soll´s ja auch geben) werden nur }
{ mit Pseudo-Tabs und ·´s übersetzt (ohne <UL>, <LI>) }
{ - wenig sinnvolle RTF-Dokumente mit Punkten im Inhaltsverzeichnis, }
{ zu denen keine entsprechende Überschrift existiert verursachen }
{ HTML-Dokumente mit Phantasie-Referenzen }
{ }
{ Folgendes wird in der vorliegenden Version ignoriert: }
{ }
{ - Kopf-/Fußzeile }
{ - File Tables }
{ - Bilder (Text-Hinweis wird im Html-Dokument angezeigt) }
{ - bestimmte rtf-spezifische Formatierungen }
{ - Dokument-Infos }
{ }
{ ************************************************************************ }
{ History: }
{ }
{ V 1.0: - erste offizielle Version }
{ }
{ V 1.1: - Bug in IgnoreGroup() entfernt (Index binind wurde nicht erhöht) }
{ - Function empty() zum Leeren der Stacks }
{ - Änderung bei der Behandlung von Gruppen-Enden }
{ - Änderung bei der Darstellung von Bullet-Listen }
{ }
{ V 1.2: - Übersetzung von Tabellen (neue Prozedur ProcessTable() ) }
{ - erweiterte Sonderzeichen-Behandlung }
{ - Aufzählungen/Listen werden jetzt als Symbol+Text nach HTML }
{ konvertiert (ohne <UL> bzw. <OL>-Tags) }
{ - kleine Layout-Bereinigungen }
{ }
{ V 1.3: - Änderung bei der Behandlung von Gruppen-Anfängen (neue Pro- }
{ zeduren CopyStack(), CopyAttrib() ) }
{ - neue Prozedur htmlchar() zur korrekten Ausgabe von Dokument- }
{ Text }
{ - Bug in chfmt() entfernt (in einzelnen Fällen wurden Format- }
{ Flags falsch gesetzt) }
{ }
{ V 2.0: - Einbindung von Stylesheets (neue Procedures initstyles(), }
{ plainchar() ) }
{ - Inhaltsverzeichnis/Überschrift-Verweis-Strukturen werden }
{ in HTML-Sprungmarken umgewandelt }
{ - Wörter, die mit ´http://´ beginnen, werdem automatisch in }
{ Hyperlinks umgewandelt (neue Prozedur incl_hlink() ) }
{ - Aufzählungen (auch geschachtelt) werden als entsprechend }
{ strukturierte <UL>´s nach HTML konvertiert }
{ - verbesserte HTML-Code-Optimierfunktion }
{ - neue Procedures addfontname(), addcolstr(), add_ks() zur }
{ Unterstützung von optim() }
{ - Aufrufparameter für rtf2html() zum Variieren der Konvertier- }
{ Vorgangsweisen }
{ - Globale Liste von ´left indents´, womit Einzüge bei Auf- }
{ zählungen im RTF-Doc. in (halbwegs) entsprechend tiefe }
{ <UL>-Schachtelungen umgewandelt werden }
{ - diverse kleine Layout-Änderungen }
{ }
{ V 2.1: - überarbeiteter Formatierungs-Algorithmus }
{ - alle left indents werden nun mittels <UL>-Schachtelungen, }
{ so weit möglich, übersetzt }
{ }
{ ************************************************************************ }

procedure add_ks (st: string);
var
helpp : strlptr;
begin
New(helpp);
helpp^.lstring := st;
helpp^.next := killstr;
killstr := helpp;
end;

procedure init_killstr;
begin
killstr := NIL;
add_ks(´<FONT SIZE=-2></FONT>´);
add_ks(´<FONT SIZE=-1></FONT>´);
add_ks(´<FONT SIZE=+0></FONT>´);
add_ks(´<FONT SIZE=+1></FONT>´);
add_ks(´<FONT SIZE=+2></FONT>´);
add_ks(´<FONT SIZE=+3></FONT>´);
add_ks(´<FONT SIZE=+4></FONT>´);
end;

function optim (src: string): string; { eliminiert überflüssige Formatierungs-Anweisungen }
var
line, comp : string;
helpp : strlptr;

begin
line := src;

repeat
comp := line;

if flag.optimize then
begin
line := ReplaceAll([´<B></B>´,´<I></I>´,´<U></U>´,´</B><B>´,´</I><I>´,´</U><U>´],[´´,´´,´´,´´,´´,´´],line);
line := ReplaceAll([´<SUP></SUP>´,´<SUB></SUB>´,´<S></S>´,´</SUP><SUP>´,´</SUB><SUB>´,´</S><S>´],[´´,´´,´´,´´,´´,´´],line);
line := ReplaceAll([´<CENTER></CENTER>´,´</CENTER><CENTER>´,´<DIV ALIGN=right></DIV>´,´</DIV><DIV ALIGN=right>´],[´´,´´,´´,´´],line);
end;

line := ReplaceAll([´<UL></UL>´,´</UL><UL>´],[´´,´´],line);

if flag.optimize then
begin
helpp := killstr;
while (helpp <> NIL) do
begin
line := ReplaceIn(helpp^.lstring, ´´, line);
helpp := helpp^.next;
end;
end;

until line = comp;

Result := line;
end;

{ ************************************************************************ }

procedure incl_hlink (var line: string);
var
helpstr, htxt, str : string;
h, h_end, strlen : integer;

begin
str := line;

h := Pos(´http://´, str);
helpstr := ´´;

while h > 0 do
begin
h_end := h + 7;
strlen := length(str);

while (str[h_end] <> ´<´)
and (str[h_end] <> ´ ´)
and (str[h_end] <> ´,´)
and (h_end <= strlen) do
Inc(h_end);

htxt := Copy(str, h, h_end-h);
helpstr := helpstr + Copy(str, 1, h-1) + ´<A HREF="´ + htxt + ´">´ + htxt + ´</A>´;
str := Copy(str, h_end, length(str));

h := Pos(´http://´, str);
end;

line := helpstr + str;
end;

{ ************************************************************************ }

procedure WriteHtml (const txt: string; var outstring: string; var outfile: textfile);
var
i, strlen: integer;
str, htxt: string;
par, br: boolean;

begin
if length(txt) > 0 then
begin
outstring := outstring + txt;

par := false;
br := false;

str := optim(outstring);

strlen := length(str);

i := Pos(´<P>´, str) + 2;
if i = 2 then
begin
i := Pos(´<BR>´, str) + 3;
if i > 3 then br := true;
end
else
par := true;

if (br) or (par) or (strlen > 100) then
begin
while par or br do
begin
htxt := Copy(str, 1, i);
incl_hlink(htxt);

WriteLn(outfile, htxt);
str := Copy(str, i+1, length(str)-i);

par := false;
br := false;

i := Pos(´<P>´, str) + 2;
if i = 2 then
begin
i := Pos(´<BR>´, str) + 3;
if i > 3 then br := true;
end
else
par := true;
end;

outstring := str;
strlen := length(str);

if (strlen > 100)
and (outstring[strlen] = ´>´)
and (outstring[strlen-1] <> ´L´)
and (outstring[strlen-1] <> ´A´) then
begin
incl_hlink(outstring);
WriteLn(outfile, outstring);
outstring := ´´;
end;
end;
end; { if length(txt) > 0 ... }
end;

{ ************************************************************************ }

function hex2dec (hex: string): integer; { hexadezimal -> dezimal - Konvertierung für Zahlen <= 255 }
var
i : integer;

begin
Result := 0;
for i := 1 to 2 do
if (hex[i] = ´A´) or (hex[i] = ´a´) then Result := Result*16 + 10
else if (hex[i] = ´B´) or (hex[i] = ´b´) then Result := Result*16 + 11
else if (hex[i] = ´C´) or (hex[i] = ´c´) then Result := Result*16 + 12
else if (hex[i] = ´D´) or (hex[i] = ´d´) then Result := Result*16 + 13
else if (hex[i] = ´E´) or (hex[i] = ´e´) then Result := Result*16 + 14
else if (hex[i] = ´F´) or (hex[i] = ´f´) then Result := Result*16 + 15
else Result := Result*16 + strtoint(hex[i]);
end;

{ ************************************************************************ }

function dec2hex (num: integer): string; { dezimal -> hexadezimal - Konvertierung für Zahlen <= 255 }
var
hex : string;
digit : integer;
begin
hex := ´´;
digit := num div 16;

while length(hex) < 2 do
begin
if digit <= 9 then
hex := hex + inttostr(digit)
else if digit = 10 then
hex := hex + ´A´
else if digit = 11 then
hex := hex + ´B´
else if digit = 12 then
hex := hex + ´C´
else if digit = 13 then
hex := hex + ´D´
else if digit = 14 then
hex := hex + ´E´
else if digit = 15 then
hex := hex + ´F´;

digit := num mod 16;
end;

Result := hex;
end;

{ ************************************************************************ }

procedure addcolstr (colstr: string);
var
str : string;

begin
str := ´<FONT COLOR="´ + colstr + ´"></FONT>´;
add_ks(str);
end;

{ ************************************************************************ }

procedure addfontname (fname: string);
var
str : string;

begin
str := ´<FONT FACE="´ + fname + ´"></FONT>´;

add_ks(str);

if not flag.onlyDefiniteOpt then { das kann u.u. ins Auge gehen, optimiert aber sehr gut }
begin { vor allem bei <UL>´s }
str := ´</FONT><FONT FACE="´ + fname + ´">´; { das </FONT> zu Beginn könnte aber von einer anderen }
add_ks(str); { Formatierung als <FONT FACE = "fname"> stammen }
end;
end;

{ ************************************************************************ }

procedure cut_tag (rtf_tag : string; var line : string); { verkürzt Stylesheet-Strings }
var
i, strlen : integer;
act_tag : string;

begin
i := Pos(rtf_tag, line);
while i > 0 do
begin
strlen := length(line);
act_tag := rtf_tag;
Inc(i, length(rtf_tag));

while (line[i] <> ´\´) and (line[i] <> ´ ´) and (i <= strlen) do
begin
act_tag := act_tag + line[i];
Inc(i);
end;

line := ReplaceIn (act_tag, ´´, line);
i := Pos(rtf_tag, line);
end;
end;

{ ************************************************************************ }

function optStyle(basestyle, actstyle: string) : string;
var
sbased, sact : string;

begin
Result := ´´;
sbased := basestyle;
sact := actstyle;

sact := ReplaceAll([´\widctlpar´,´\adjustright´,´\nowidctlpar´],[´´,´´,´´], sact);
sact := ReplaceAll([´\keepn´,´\cgrid´,´\widctl´],[´´,´´,´´], sact);

cut_tag(´\sbasedon´, sact);
cut_tag(´\snext´, sact);
cut_tag(´\sa´, sact);
cut_tag(´\sb´, sact);
cut_tag(´\lang´, sact);
cut_tag(´\slmult´, sact);
cut_tag(´\sl´, sact);
cut_tag(´\outlinelevel´, sact);
cut_tag(´\kerning´, sact);
cut_tag(´\expndtw´, sact);
cut_tag(´\expnd´, sact);
cut_tag(´\tx´, sact);

if pos(sbased, sact) > 0 then
begin
sbased := ´´;
end;
if ((pos(´\fi´, sact) > 0) or (pos(´\li´, sact) > 0))
and ((pos(´\fi´, sbased) > 0) or (pos(´\li´, sbased) > 0)) then
begin
cut_tag(´\fi´, sbased);
cut_tag(´\li´, sbased);
end;

Result := sbased + sact;
end;

{ ************************************************************************ }

procedure CloseLists (var outstring: string; var outfile: textfile);
var
txt : string;

begin
txt := ´´;

if listitem and not li_open then
txt := txt + ´</LI>´;

while enums.lvl > 0 do
begin
txt := txt + ´</UL>´;
Dec(enums.lvl);
end;

WriteHtml(txt, outstring, outfile);
end;

{ ************************************************************************ }

function htmlcol (rtfcol: string): string; { wandelt rft-Farbangabe in html-Farbangabe um }
var
red_ind, green_ind, blue_ind : integer;
redstr, greenstr, bluestr, colstr : string;
red, green, blue : integer;

begin
redstr := ´´;
greenstr := ´´;
bluestr := ´´;

red_ind := pos(´red´,rtfcol)+3;
green_ind := pos(´green´,rtfcol)+5;
blue_ind := pos(´blue´,rtfcol)+4;

while (rtfcol[red_ind] in [´0´..´9´]) and (red_ind <= length(rtfcol)) do
begin
redstr := redstr + rtfcol[red_ind];
Inc(red_ind);
end;
try
red := strtoint(redstr);
except
on EConvertError do red := 0;
end;
redstr := dec2hex(red);

while (rtfcol[green_ind] in [´0´..´9´]) and (green_ind <= length(rtfcol)) do
begin
greenstr := greenstr + rtfcol[green_ind];
Inc(green_ind);
end;
try
green := strtoint(greenstr);
except
on EConvertError do green := 0;
end;
greenstr := dec2hex(green);

while (rtfcol[blue_ind] in [´0´..´9´]) and (blue_ind <= length(rtfcol)) do
begin
bluestr := bluestr + rtfcol[blue_ind];
Inc(blue_ind);
end;
try
blue := strtoint(bluestr);
except
on EConvertError do blue := 0;
end;
bluestr := dec2hex(blue);

colstr := ´´+redstr+greenstr+bluestr;
Result := colstr;
end;

{ ************************************************************************ }

procedure resetfmt (var attrib: formata; const kind: string); { setzt intern gespeicherte Formatierungen zurück }
begin
with attrib do
begin
if (kind = ´text´) or (kind = ´all´) then
begin
invis := false;
caps := false;
bold := false;
italic := false;
underline := false;
superscript := false;
subscript := false;
strike := false;
font:= -1;
fcol:= ´none´;
fsize:= -1;
end;
if (kind = ´par´) or (kind = ´all´) then
begin
rjustified := false;
centered := false;
end;
if (kind = ´all´) then table := 0;
end;
end;

{ ************************************************************************ }

function diff(attr1: formata; attr2: formata): boolean; { vergleicht zwei Format-Records }
begin
Result := false;

if attr1.invis <> attr2.invis then
Result := true
else if attr1.bold <> attr2.bold then
Result := true
else if attr1.italic <> attr2.italic then
Result := true
else if attr1.underline <> attr2.underline then
Result := true
else if attr1.superscript <> attr2.superscript then
Result := true
else if attr1.subscript <> attr2.subscript then
Result := true
else if attr1.strike <> attr2.strike then
Result := true
else if attr1.font <> attr2.font then
Result := true
else if attr1.fcol <> attr2.fcol then
Result := true
else if attr1.fsize <> attr2.fsize then
Result := true
else if attr1.rjustified <> attr2.rjustified then
Result := true
else if attr1.centered <> attr2.centered then
Result := true;
end;

{ ************************************************************************ }

function htmlfontsize (size: integer): string; { liefert den html-Code für die angegebene neue Schrift-Größe }
var
sizestr: string;

begin
if (size <> 12) then
begin { wir interpolieren..... }
if size <= 8 then sizestr := ´-2´
else if size <= 11 then sizestr := ´-1´
else if size <= 15 then sizestr := ´+1´
else if size <= 20 then sizestr := ´+2´
else if size <= 28 then sizestr := ´+3´
else sizestr := ´+4´;
Result := ´<FONT SIZE=´ + sizestr + ´>´;
end
else
Result := ´<FONT SIZE=+0>´;
end;

{ ************************************************************************ }

function fontname (var num: integer): string;
var
i : integer;

begin
i := 0;
while (fonts[i].number <> num) and (i < high(fonts)) do Inc(i);

if i > high(fonts) then { sollte eigentlich nicht vorkommen..... }
begin
num := fonts[high(fonts)].number;
Result := fonts[high(fonts)].name;
end
else
Result := fonts[i].name;
end;

{ ************************************************************************ }

procedure CopyAttrib(var dest: formata; src: formata);
begin
dest.invis := src.invis;
dest.caps := src.caps;
dest.bold := src.bold;
dest.italic := src.italic;
dest.underline := src.underline;
dest.superscript := src.superscript;
dest.subscript := src.subscript;
dest.strike := src.strike;
dest.font := src.font;
dest.fcol := src.fcol;
dest.fsize := src.fsize;
dest.rjustified := src.rjustified;
dest.centered := src.centered;
{ dest.table := src.table;}
end;

{ ************************************************************************ }

procedure addtag(var stk: stackptr; tagstart: string; tagend: string);
var { neue Formatierung auf den Stack ..... }
ptr : stackptr;
begin
New(ptr);
ptr^.tagstart := tagstart;
ptr^.tagend := tagend;
ptr^.next := stk;
stk := ptr;
end;

{ ************************************************************************ }

procedure CopyStack(var dest: stackptr; src: stackptr);
var
helpptr : stackptr;
begin
dest := NIL;
helpptr := src;
while (helpptr <> NIL) do
begin
addtag(dest, helpptr^.tagstart, helpptr^.tagend);
helpptr := helpptr^.next;
end;
end;

{ ************************************************************************ }

procedure poptag(var stk: stackptr);
var { oberste Formatierung vom Stack entfernen }
ptr : stackptr;
begin
ptr := stk;
stk := stk^.next;
Dispose(ptr);
end;

{ ************************************************************************ }

function contents(stk: stackptr): string;
var
helpp : stackptr;

begin
helpp := stk;
Result := ´´;
while (helpp <> NIL) do
begin
if copy(helpp^.tagend,1,6) = ´</FONT´ then
Result := Result + ´</FONT>´
else
Result := Result + helpp^.tagend;
helpp := helpp^.next;
end;
end;

{ ************************************************************************ }

function empty(var stk: stackptr): string;
begin
Result := ´´;
while (stk <> NIL) do
begin
if copy(stk^.tagend,1,6) = ´</FONT´ then
Result := Result + ´</FONT>´
else
Result := Result + stk^.tagend;
poptag(stk);
end;
end;

{ ************************************************************************ }

function createFTags (attrib: formata): string;
var
txt : string;

begin
Result := ´´;
with attrib do
begin
if bold then
begin
addtag(mainstack, ´<B>´, ´</B>´);
Result := Result + ´<B>´;
end;
if italic then
begin
addtag(mainstack, ´<I>´, ´</I>´);
Result := Result + ´<I>´;
end;
if underline then
begin
addtag(mainstack, ´<U>´, ´</U>´);
Result := Result + ´<U>´;
end;
if subscript then
begin
addtag(mainstack, ´<SUB>´, ´</SUB>´);
Result := Result + ´<SUB>´;
end;
if superscript then
begin
addtag(mainstack, ´<SUP>´, ´</SUP>´);
Result := Result + ´<SUP>´;
end;
if strike then
begin
addtag(mainstack, ´<S>´, ´</S>´);
Result := Result + ´<S>´;
end;
if fcol <> ´none´ then
begin
txt := ´<FONT COLOR="´ + fcol + ´">´;
addtag(mainstack, txt, ´</FONT>´);
Result := Result + txt;
end;
if font > -1 then
begin
txt := fontname(font);
txt := ´<FONT FACE="´ + txt + ´">´;
addtag(mainstack, txt, ´</FONT>´);
Result := Result + txt;
end;
if fsize > -1 then
begin
txt := htmlfontsize(fsize);
addtag(mainstack, txt, ´</FONT>´);
Result := Result + txt;
end;
end;
end;

{ ************************************************************************ }

function htmlchar(ch: string; attrib: formata): string;
var
ltr : char;
curlink, curanch : string;

begin
Result := ´´;

if changefmt then
Result := Result + empty(mainstack);

if nextpar then
begin
if attrib.centered then
Result := Result + ´<CENTER>´
else if attrib.rjustified then
Result := Result + ´<DIV ALIGN=right>´;
end;

if changefmt or nextpar then
begin
Result := Result + CreateFTags(attrib);
end;

enums.doclvl := globbrk;
nextpar := false; { wir sind nicht mehr am Beginn eines neuen Absatzes }
changefmt := false;

if ahrefwait then
begin
if newhrefnum then { jetzt wird´s Zeit, eine Referenz zu setzen }
begin
ahref := true;
newhrefnum := false;
Inc(actlinknum[indexlvl]);
curlink := inttostr(indexlvl) + ´-´ + inttostr(actlinknum[indexlvl]);
Result := Result + ´<A HREF="´ + curlink + ´">´;
end;
end;

if anchor then
begin { jetzt kommt eine Sprungmarke }
Inc(actanchnum[anchlvl]);
curanch := inttostr(anchlvl) + ´-´ + inttostr(actanchnum[anchlvl]);
Result := Result + ´<A NAME="´ + curanch + ´">´;
end;

if not attrib.invis then
begin
if length(ch) = 1 then
begin
ltr := ch[1];
if ltr = ´<´ then
Result := Result + ´&´
else if ltr = ´>´ then
Result := Result + ´&´
else if ltr = ´&´ then
Result := Result + ´&´
else
if ltr in [´a´..´z´] then
begin
if attrib.caps then
Result := Result + UpperCase(ltr)
else
Result := Result + ltr;
end
else
Result := Result + ltr;
end
else if (length(ch) = 2) then
begin
if ch = ´c4´ then Result := Result + ´Ä´ { ´Ä´ }
else if ch = ´d6´ then Result := Result + ´Ö´ { ´Ö´ }
else if ch = ´dc´ then Result := Result + ´Ü´ { ´Ü´ }
else if ch = ´e4´ then { ´ä´ }
begin
if attrib.caps then
Result := Result + ´Ä´
else
Result := Result + ´&´;
end
else if ch = ´f6´ then { ´ö´ }
begin
if attrib.caps then
Result := Result + ´Ö´
else
Result := Result + ´&´;
end
else if ch = ´fc´ then { ´ü´ }
begin
if attrib.caps then
Result := Result + ´Ü´
else
Result := Result + ´&´;
end
else if ch = ´df´ then Result := Result + ´&´ { ´ß´ }
else if ch = ´b7´ then Result := Result + ´&´ { Aufzählungs-Punkt }
else Result := Result + chr(hex2dec(ch));
end { if length(ch) = 1 ... }
else
begin
if ch = ´&´ then
Result := Result + ´<P>[*** picture ***]<P>´ { Graphik-Substitut}
else if (Pos(´&&´, ch) = 1) then
Result := Result + Copy(ch, 3, length(ch)-2) { Aufzählungstext }
else if ch = ´&´ then
Result := Result + ´&&&&&&&&´
else if ch = ´&´ then
Result := Result + 39
else if ch = ´&´ then
Result := Result + 34
else if ch = ´&´ then
Result := Result + ´&&´
else if ch = ´&´ then
Result := Result + ´&´
else if ch = ´&´ then
Result := Result + ´--´
else if ch = ´&´ then
Result := Result + ´-´
else if ch = ´&´ then
Result := Result + ch; { nonbreaking space }
end;
end
else { hidden text }
Result := Result + ´´;

if anchor then
begin
Result := Result + ´</A>´;
anchor := false;
end;
end;

{ ************************************************************************ }

function plainchar(ch: string): string;
begin
if ch = ´c4´ then Result := ´Ä´
else if ch = ´d6´ then Result := ´Ö´
else if ch = ´dc´ then Result := ´Ü´
else if ch = ´e4´ then Result := ´ä´
else if ch = ´f6´ then Result := ´ö´
else if ch = ´fc´ then Result := ´ü´
else if ch = ´df´ then Result := ´ß´
else Result := chr(hex2dec(ch));
end;

{ ************************************************************************ }

function html (const ctrlword: string; var attrib: formata): string;
var { frißt rtf-Kontrollwort & spuckt entsprechenden html-Code aus }
num : integer;
txt : string;

begin
Result := ´´;

if (ctrlword = ´plain´) or (ctrlword = ´pard´) or (ctrlword = ´sectd´) then { alle Formatierungen deaktivieren }
begin
if (ctrlword = ´plain´) then
begin
resetfmt(attrib, ´text´);
changefmt := true;
if mainstack <> NIL then
Result := Result + empty(mainstack);
end;

if (ctrlword = ´pard´) or (ctrlword = ´sectd´) then { neue Absatz-Formatierung }
begin
resetfmt(attrib, ´par´);

enumtxt := ´´;
txtwait := ´´;
ahrefwait := false;
lastindent := 0;
no_newind := true;
li_open := false;
listbull := false;
enumdigit := false;
pnnum := false;
lvlnum := -1;

{ if listitem then
Result := Result + ´</LI>´; }

while enums.lvl > 0 do
begin
Dec(enums.lvl);
txt := txt + ´</UL>´;
end;
listitem := false;
end;

if txt <> ´´ then Result := Result + txt;
end

else if ctrlword = ´v´ then { versteckter Text }
attrib.invis := true

else if ctrlword = ´v0´ then
attrib.invis := false

else if ctrlword = ´caps´ then { Blockschrift }
attrib.caps := true

else if ctrlword = ´caps0´ then
attrib.caps := false

else if ctrlword = ´tab´ then { Tabulator }
begin { Notlösung }
if not attrib.invis then Result := Result + htmlchar(´&´, attrib);
end

else if ctrlword = ´qc´ then { Formatierung: zentriert }
begin
if not attrib.centered then
begin
attrib.centered := true;
end;
end

else if ctrlword = ´qr´ then { Formatierung: rechtsbündig }
begin
if not attrib.rjustified then
begin
attrib.rjustified := true;
end;
end

else if (ctrlword = ´par´) or (ctrlword = ´sect´) then { neuer Absatz }
begin
Result := Result + empty(mainstack);

if attrib.rjustified then
begin
Result := Result + ´</DIV>´;
end;
if attrib.centered then
begin
Result := Result + ´</CENTER>´;
end;

changefmt := true;
newhrefnum := true;
nextpar := true;

if listitem then
begin
Result := Result + ´</LI>´;
li_open := true;
end
else
begin
Result := Result + ´<BR>´;
if lvlnum > -1 then
begin
Inc(lvlnum);
enumtxt := pntxtb + inttostr(lvlnum) + pntxta;
end;
bkmkpar := false;
end;
end

else if (ctrlword = ´line´) then { Zeilenumbruch }
begin
Result := Result + ´<BR>´;
end

else if (ctrlword = ´page´)then { Seitenumbruch }
begin
Result := Result + ´<BR><HR><BR>´;
end

else if (ctrlword = ´emdash´) then { langer Gedankenstrich }
begin
if not attrib.invis then Result := Result + htmlchar(´&´, attrib);
end

{ das hier muß ALLES von htmlchar übernommen werden }

else if (ctrlword = ´endash´) then { kurzer Gedankenstrich }
begin
if not attrib.invis then Result := Result + htmlchar(´&´, attrib);
end

else if (ctrlword = ´emspace´) then { langer Zwischenraum }
begin
if not attrib.invis then Result := Result + htmlchar(´&´, attrib);
end

else if (ctrlword = ´enspace´) then { kurzer Zwischenraum }
begin
if not attrib.invis then Result := Result + htmlchar(´&´, attrib);
end

else if (ctrlword = ´lquote´) or (ctrlword = ´rquote´) then { einfaches Anführungszeichen, Apostroph }
begin
if not attrib.invis then Result := Result + htmlchar(´&´, attrib);
end

else if (ctrlword = ´ldblquote´) or (ctrlword = ´rdblquote´) then { doppeltes Anführungszeichen }
begin
if not attrib.invis then Result := Result + htmlchar(´&´, attrib);
end

else if ctrlword = ´b´ then { Formatierung: fett }
begin
if not attrib.bold then
begin
changefmt := true;
attrib.bold := true;
end;
end

else if ctrlword = ´b0´ then
begin
if attrib.bold then
begin
changefmt := true;
attrib.bold := false;
end;
end

else if ctrlword = ´i´ then { Formatierung: kursiv }
begin
if not attrib.italic then
begin
changefmt := true;
attrib.italic := true;
end;
end

else if ctrlword = ´i0´ then
begin
if attrib.italic then
begin
changefmt := true;
attrib.italic := false;
end;
end

else if (ctrlword = ´ul´) { Formatierung: unterstreichen }
or (ctrlword = ´uld´)
or (ctrlword = ´uldash´)
or (ctrlword = ´uldashd´)
or (ctrlword = ´uldashdd´)
or (ctrlword = ´uldb´)
or (ctrlword = ´ulth´)
or (ctrlword = ´ulwave´) then
begin
if not attrib.underline then
begin
changefmt := true;
attrib.underline := true;
end;
end

else if (ctrlword = ´ulnone´) or (ctrlword = ´ul0´) then { Formatierung: unterstreichen beenden }
begin
if attrib.underline then
begin
changefmt := true;
attrib.underline := false;
end;
end

else if (ctrlword = ´super´) or (pos(´up´,ctrlword) = 1) then { Formatierung: hochstellen }
begin
if not attrib.superscript then
begin
changefmt := true;
attrib.superscript := true;
end;
end

else if (ctrlword = ´sub´) or (pos(´dn´,ctrlword) = 1) then { Formatierung: tiefstellen }
begin
if not attrib.subscript then
begin
changefmt := true;
attrib.subscript := true;
end;
end

else if (ctrlword = ´nosupersub´) then { Formatierung: hoch-/tiefstellen beenden }
begin
if attrib.superscript or attrib.subscript then
begin
changefmt := true;
attrib.superscript := false;
attrib.subscript := false;
end;
end

else if (ctrlword = ´strike´) or (ctrlword = ´strikedl´) then { Formatierung: durchstreichen }
begin
if not attrib.strike then
begin
changefmt := true;
attrib.strike := true;
end;
end

else if (ctrlword = ´strike0´) or (ctrlword = ´strikedl0´) then
begin
if attrib.strike then
begin
changefmt := true;
attrib.strike := false;
end;
end

else if pos(´li´,ctrlword) = 1 then
begin
if (ctrlword[3] in [´0´..´9´]) and (attrib.table = 0) then
begin
try
num := strtoint(copy(ctrlword,3,length(ctrlword)-2));
except
on EConvertError do
num := 0;
end;

if no_newind then
begin
lastindent := lastindent + num;
no_newind := false;

while (enums.indent[enums.lvl] < lastindent) and (enums.lvl <= 20)
do
begin
Inc(enums.lvl);
Result := Result + ´<UL>´;
end;
end;
end;
end

else if pos(´fi´,ctrlword) = 1 then
begin
if ctrlword[3] in [´0´..´9´,´-´] then
begin
try
num := strtoint(copy(ctrlword,3,length(ctrlword)-2));
except
on EConvertError do
num := 0;
end;

if no_newind then
begin
lastindent := lastindent + num;
end;
end;
end

else if pos(´f´,ctrlword) = 1 then
begin
if (ctrlword[2] in [´0´..´9´]) and (not flag.noFonts) then { neue Schriftart }
begin
try
num := strtoint(copy(ctrlword,2,length(ctrlword)-1));
except
on EConvertError do
num := 0;
end; { Font-Nummer erfassen }

if attrib.font <> num then
begin
changefmt := true;
attrib.font := num;
end;
end
else if ctrlword[2] = ´s´ then { neue Schrift-Größe }
begin
try
num := strtoint(copy(ctrlword,3,length(ctrlword)-2));
except
on EConvertError do { Schrift-Größen-Zahl erfassen }
num := 0;
end;
num := num div 2; { Schrift-Größen in RTF sind in halben Punkten angegeben }

if attrib.fsize <> num then
begin
changefmt := true;
attrib.fsize := num;
end;
end;
end

else if pos(´cf´,ctrlword) = 1 then { neue Vordergrund-Farbe }
begin
try
num := strtoint(copy(ctrlword,3,length(ctrlword)-2));
except
on EConvertError do { Farb-Nummer erfassen }
num := 0;
end;

if num > col.count-1 then
txt := col[col.count-1] { sollte auch nicht vorkommen }
else
txt := col[num];

if attrib.fcol <> txt then
begin
changefmt := true;
attrib.fcol := txt;
end;
end;
end;

{ ************************************************************************ }

function LineAt (const index: integer; const line: string; var infile: textfile): string;
var { liefert einen Teilstring von ´line´ ab Position ´index´ }
nextstr, str : string; { zurück. Ist ´line´ kürzer als ´index´, wird eine }
begin { neue Zeile eingelesen und an ´line´ angehängt, und dies }
str := line; { bei Bedarf so lange wiederholt, bis ´index´ kleiner als }
while (not EOF(infile)) and (index > length(str)) do { die Zeilenlänge ist und somit das gewünschte Resultat }
begin { geliefert werden kann }
ReadLn(infile, nextstr);
str := str + nextstr;
end;

if index > length(str) then { gesuchte Stelle existiert im Input-File gar nicht mehr }
Result := ´´
else
Result := Copy(str,index,length(str)-index+1);
end;

{ ************************************************************************ }

procedure IgnoreGroup(var line: string; var infile: textfile); { springt zum Ende der aktuellen Group }
var
lastline : boolean;
i, brk, strlen : integer;
binlen, binind : longint;

begin
lastline := false;
i := 0;
strlen := 0;
brk := 0; { zählt die geschwungenen Klammern }

while (not lastline) and (brk > -1) do
begin
if EOF(infile) then lastline := true;
strlen := length(line);
i := 1;
while (i <= strlen) and (brk > -1) do
begin
if line[i] = ´\´ then
begin
if pos(´bin´,line) = i+1 then { bei Binär-Daten im RTF-File funktioniert das Klammern-Zählen }
begin { nicht und daher wird die im ´bin´-tag angegebene Menge von }
binlen := 0; { Bytes ungeprüft übersprungen }
i := i+4;
while (line[i] in [´0´..´9´]) and (i <= strlen) do
begin { Länge der Binär-Daten erfassen }
binlen := binlen * 10 + strtoint(line[i]);
Inc(i);
end;
binind := 1;
while (binind <= binlen) and (not (EOF(infile) and (i > strlen)) ) do
begin { Binär-Daten überspringen }
if EOF(infile) then lastline := true;
if (i > strlen) and (not lastline) then
begin
ReadLn(infile, line);
Inc(binind);
if EOF(infile) then lastline := true;
i := 1;
end
else
begin
Inc(i);
Inc(binind);
end;
end;
end;
end;

if line[i] = ´{´ then Inc(brk)
else if line[i] = ´}´ then Dec(brk);

Inc(i);
end;

if (brk > -1) and not lastline then ReadLn(infile, line); { noch immer in in der Group --> nächste Zeile }
end;

if (i > strlen) and not lastline then
begin
ReadLn(infile, line); { letztes Zeichen der Zeile war Group-Ende --> weiter mit neuer Zeile }
line := ´}´ + line;
end
else line := LineAt(i-1, line, infile); { sonst: Zeile := Zeile ab Group-Ende }
end;

{ ************************************************************************ }

procedure setfonts (var infile, outfile: textfile; var src: string);
var
fnum, ftind, i, i2, strlen: integer;
endfonts, lastline: boolean;
nextstr: string;

begin
ftind := 0;
endfonts := false;
lastline := false;
i := pos(´\fonttbl´,src)+8;
strlen := length(src);

While not lastline and not endfonts do
begin
if EOF(infile) then lastline := true;
while (i <= strlen) and (src[i] <> ´\´) do Inc(i); { Font-Deklaration suchen }
Inc(i);
if i > strlen then Exit;
{ Fehler im Format }

fnum := 0;
if src[i] = ´f´ then
begin
Inc(i);
while (src[i] in [´0´..´9´]) and (i <= strlen) do { Font-Nummer }
begin
fnum := (fnum*10)+strtoint(src[i]);
Inc(i);
end;

{ nun wird der Anfang des Font-Namens gesucht }
while (i <= strlen) and (src[i] <> ´}´) and (src[i] <> ´{´) and (src[i] <> ´ ´) do Inc(i);
if src[i] = ´{´ then
while (i <= strlen) and (src[i] <> ´}´) do Inc(i);
Inc(i);
if i > strlen then Exit;

{ und nun das Ende..... }
i2 := i;
while (i2 <= strlen) and (src[i2] <> ´;´) and (src[i2] <> ´{´) and (src[i2] <> ´\´) do Inc(i2);
if (src[i2] = ´{´) and (pos(´\*\falt´,src) = i2+1) then
begin
i := i2+9;
while (i2 <= strlen) and (src[i2] <> ´}´) do Inc(i2);
end;
if i2 > strlen then Exit; { Fehler im Format }

if not flag.noFonts then
begin
with fonts[ftind] do
begin
name := Copy(src,i,i2-i); { Font-Name }
number := fnum;
if (flag.optimize) and (ftind < fontsOpt) then
addfontname(name); { KillStrings zum späteren Optimieren setzen }
end; { für die ersten <fontsOpt> deklarierten Schriften }
Inc(ftind);
end;

src := Copy(src,i2,strlen-i2+1);

while (length(src) < 5) and (not lastline) do
begin { Deklaration in nächster Zeile fortgesetzt }
if EOF(infile) then
lastline := true
else
ReadLn(infile,nextstr);
src := src + nextstr;
end;

strlen := length(src);
i := 0;

while (i <= strlen) and (src[i] <> ´}´) do Inc(i);

if i > strlen then Exit;
{ Fehler im Format }

if (src[i] = ´}´) and (src[i+1] = ´}´) then
begin
endfonts := true;
src := Copy(src,i+1,strlen-i);
end
{ \fonttbl beendet }
else
begin
while (i <= strlen) and (src[i] <> ´{´) do Inc(i);
{ Suche nach nächster Font-Deklaration }
if i > strlen then Exit;
{ Fehler im Format }
src := Copy(src,i,strlen-i+1);
strlen := length(src);
i := 0;
end;
end
else
Exit;
end;
end;

{ ************************************************************************ }

procedure setcolours (var infile, outfile: textfile; var src: string);
var
i, i2, strlen : integer;
endcolours, lastline : boolean;
colstr, nextstr : string;

begin
endcolours := false;
lastline := false;
i := pos(´\colortbl´,src)+9;
strlen := length(src);

if (src[i] = ´;´) then col.add(´000000´); { "auto" color (Farbe 0) nicht gesetzt --> schwarz }

While not lastline and not endcolours do
begin
if EOF(infile) then lastline := true;

while (i <= strlen) and (src[i] <> ´\´) do Inc(i); { Farb-Deklaration suchen }
i2 := i;
while (i2 <= strlen) and (src[i2] <> ´;´) do Inc(i2); { das Ende ebendieser suchen }

if i2 > strlen then Exit; { Fehler im Format }
if (src[i2+1] = ´}´) then endcolours := true;

colstr := htmlcol(Copy(src,i,i2-i));
col.add(colstr); { im html-Farben-Format in die Liste eintragen }

if flag.optimize then
addcolstr(colstr); { KillStrings zum späteren Optimieren setzen }

src := Copy(src,i2+1,strlen);

while (length(src) < 5) and (not EOF(infile)) do
begin { Deklaration in nächster Zeile fortgesetzt }
ReadLn(infile,nextstr);
src := src + nextstr;
end;

strlen := length(src);
i := 0;
end;
end;

{ ************************************************************************ }

procedure initstyles (var infile, outfile: textfile; var src: string);
var
i, j, hrnum, strlen, snum, sbased : integer;
endstyles, lastline, str, ctr, firststyle : boolean;
basedon, cwd, txt, nextstr, sname, snumstr, spchar : string;

begin
basedon := ´´; { Platzhalter für Basis-Styles }
spchar := ´´; { Sonderzeichen }
snum := 0; { Style-Nummer im Stylesheet }
sbased := 0;