RichEdit para HTML

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

Motta,

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

Valeu.

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...

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

Não sei se o uso é livre.

[code:1:b6c9bbc2c4]
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;