1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:

{$D-,L-,Y-}
unit rtf2html;

(*
--------------------------------------------------------------------------------

Revision history:
 Nb.   Date:         Author   What was done.
 003   ?             ?        ?
 002   21-aug-1997   TSE      Minor (very minor) cleanup before release
 001   20-aug-1997   TSE      Unit created - RtfToHTML function
                              designed and written.

Author list:
 TSE  Troels Skovmand Eriksen    TSEriksen@cyberdude.com
                                        TSErikse@post8.tele.dk
 ?      ?                               ?

Supported features:
 rev. 001  Indents, Bullets, Left-, Centered & Rightjustified text,
                Text styles (bold, italics and underline),
                Fonts (face, size, color).
 rev. 002  - do -
 rev.   3  ?

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

 This unit and all procedures and functions herein is released as
freeware. Any components or units created using this unit or
portions hereoff must be released as freeware (This does not
cover applications - they may be shareware/commercial as needed).

 Part of the function RtfToHTML may be covered by some obscure
Microsoft copyright since it reads the RTF format - check it out
yourself, if you do something worthwhile.

 Please let this preface stay if you publish a changed/updated 
version of this unit and write all changes the "Revision history" 
section above. Who-Dun-it information should be inserted in the 
"Author list" and the "Supported features" section should be updated. 
This makes it easier to pass the blame :-) 

 I'm finished with this unit for now - but please email a copy of
any changes you make to me - Troels S Eriksen.

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

 The following should be fixed - if anybody want to do it?

   * Should be rewritten into a conversion class - could be tricky, since
     it seems like a stream only contains 4 Kb at a time ...
   * Code should be cleaned up - this below is not that fast ...
   * The indents (\li###) should be translated to <BLOCKQUOTE> or
     just a <UL> with no <LI> elements.
   * The hanging paragraphs should be translated to definitionlists ( the
     <DL COMPACT> <DT> term <DD> definition </DL> structure )
   * Tabs (\tab) should be fixed somehow ( heck, I DO want
     a <TAB> code ! )
   * Embedded objects / pictures should be converted to .gif's
     - I know it's possible
   * Some nice way to handle links ( the way .rtf-sources for
     helpfiles do ? )
   * A even more nice way of handling tables - could fix the
     indent / tab-problems as well

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

 The idea and logic behind this weirdo function :

 Well, the idea was to write a pascal RTF-2-HTML converter which
doesn't just do some "search and replace" - but actually converts
the dammed stuff.

 Since there's a difference between HTML and RTF in the
code-sequencing, I decided to try storing all paragraph and
textformatting information in two records (PARFMT and
TXTFMT) and only write the contents of these to the output
"stream" when needed.

 This first attempt is successfull - not highly, but it'll convert
the contents of a TRichEdit control and most other .rtf documents
to HTML and keep the general layout.

Enjoy it
Troels S Eriksen, Denmark

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

*)
{$LONGSTRINGS ON}

interface

 function RtfToHtml(const rtf:string):string;

implementation
uses
  Classes, SysUtils;

function RtfToHtml(const rtf:string):string;

type
  TState = record
    FntTbl : boolean;
    ColTbl : boolean;
    FntLst,
    ColLst : TStringList;
  end;

  TPARFMT = record
    Alignment : TAlignment;  { højre, venstre, centreret tekst }
    Bullets   : integer;     { Skriv bulletliste   <UL>  = 1
                                     Skriv element       <LI>  = 2
                                     Skriv element slut  </LI> = 3
                                     Skriv liste slut    </UL> = 4 }
    Written   : boolean;     { true hvis skrevet til streng }
  end;

  TTXTFMT = record
    ChangeF   : boolean;
    DefFont   : integer;
    Font      : integer;
    Fontsize  : integer;
    Color     : integer;
    Bold      : integer;
    Italics   : integer;
    Underline : integer;
    Written   : boolean;
  end;

var
  indx : integer;  // index i rtf-streng
  ParFmt : TParFmt;
  TxtFmt : TTxtFmt;
  State  : TState;

  Group  : integer;
  Col    : string[10];
  Fnt    : string[63];

  procedure WriteChar(c:Char);
    var
      S : string;
    begin
      s:='';
      // First - get ready to write paragraph formatting
      With PARFMT do if not Written then begin
        // TextAttr's must be off before starting a new paragraph
{
       add "uses forms" to the implementation or interface statement,
       then call application.processmessages here - this would allow
       you to work the application interface will saving a large file.
}
        With TXTFMT do begin
          if bold>1 then begin
            s:=s+'</B>';
            if bold=3 then bold:=0;
          end;
          if italics>1 then begin
            s:=s+'</I>';
            if italics=3 then Italics:=0;
          end;
          if underline>1 then begin
            s:=s+'</U>';
            if underline=3 then Underline:=0;
          end;
        end;
        { Write either bulletlist or left-, center, rightjustified paragraph
          (doing it this way makes bulletlists leftjustified no matter what) }
        case Bullets of
          0 : case Alignment of
            taLeftJustify : s:=s+#13#10'<P>';
            taRightJustify: s:=s+#13#10'<P ALIGN=RIGHT>';
            taCenter      : s:=s+#13#10'<P ALIGN=CENTER>';
          end;
          1 : s:=s+#13#10'<UL>';
          2 : s:=s+#13#10'<LI>';
          3 : s:=s+'</LI>';
          4 : begin
            s:=s+#13#10'</UL>';
            Bullets:=0;
          end;
          5 : begin
            s:=s+'<BR>'#13#10#160#32#160#32#160;
            Bullets:=0;
          end;
        end;
        // If any textattr's was on before - they are re-enabled
        With TXTFMT do begin
          If Bold=2 then s:=s+'<B>';
          If Italics=2 then s:=s+'<I>';
          If Underline=2 then s:=s+'<U>';
        end;
        Written:=TRUE;
      end; { PARFMT }
      // Second - Write any textattr's
      With TXTFMT do if not written then begin
        // If font has changed - write it
        If changeF then begin
          s:=s+'<FONT FACE="'+state.fntlst.strings[Font]+
               '" COLOR="'+state.collst.strings[Color]+
               '" SIZE="'+IntToStr(FontSize)+'">';
          ChangeF:=FALSE;
        end;
        // If any textattr's should be written - do it
        case Bold of
          1 : begin
            s:=s+'<B>';
            bold:=2;
          end;
          3 : begin
            s:=s+'</B>';
            Bold:=0;
          end;
        end;
        case Italics of
          1 : begin
            s:=s+'<I>';
            Italics:=2;
          end;
          3 : begin
            s:=s+'</I>';
            Italics:=0;
          end;
        end;
        case Underline of
          1 : begin
            s:=s+'<U>';
            Underline:=2;
          end;
          3 : begin
            s:=s+'</U>';
            Underline:=0;
          end;
        end;
        Written:=TRUE;
      end;
      // At last - write the character it self
      case c of
        #0  : result:=result+s;          // Writes pending codes only
        #9  : result:=result+s+#9;       // Writes tab char
        '>' : result:=result+s+'>';    // Writes "greater than"
        '<' : result:=result+s+'<';    // Writes "less than"
        else  result:=result+s+c;        // Writes a character
      end;
    end; { WriteChar }

  function Resolve(c:char):integer;
  { Convert char to integer value - used to decode \'## to an ansi-value }
  begin
    case byte(c) of
      48..57 : Result:=byte(c)-48;
      65..70 : Result:=byte(c)-55;
      else     Result:=0;
    end;
  end; { resolve }

  function CollectCode(i:integer):integer;
  var
    Value,
    Keyword : string;
    a       : integer;
  begin
    KeyWord:='';
    // First - check if keyword is any "special" keyword or is a normal one ...
    case rtf[i+1] of
      '*' : begin    // Ignorre to end of group
        a:=group;
        repeat
          case rtf[i] of
            '{' : inc(group);
            '}' : dec(group);
          end;
          inc(i);
        until (group+1)=a;
        result:=i-1;
      end;
      #39 : begin  // Decode hex value 
        WriteChar(char(resolve(upcase(rtf[i+2]))*16+resolve(upcase(rtf[i+3]))));
        Inc(i,3);
        result:=i;
      end;
      '\','{','}' : begin  // Return special character
        WriteChar(rtf[i+1]);
        inc(i);
        result:=i;
      end;
      else begin
        // First - get keyword ...
        repeat
          keyword:=keyword+rtf[i];
          inc(i);
        until (rtf[i] in ['{','\','}',' ',';','-','0'..'9']);
        // Second - get any value following ...
        Value  :='';
        While (rtf[i] in ['a'..'z','-','0'..'9']) do begin
          value:=value+rtf[i];
          inc(i);
        end;
        if rtf[i]=' ' then inc(i);
        while (rtf[i] in ['{','}',';']) do inc(i);
        result:=i-1;
        { Check which keyword and what to do - NB: Test shows that using
          IF THEN ELSE .. is approx. 10% more efficient than calling EXIT }
        if keyword='\par' then with PARFMT do begin
          // New paragraph or bullet item
          if Bullets=2 then Bullets:=3;
          Written:=FALSE;
        end else if keyword='\f' then case state.fnttbl of
          true : begin                        // Make fontlist
            fnt:='';
            While rtf[i]<>' ' do inc(i);      // Ignore fontfamily info etc
            inc(i);
            While rtf[i]<>';' do begin        // Read font name
              Fnt:=Fnt+rtf[i];
              inc(i);
            end;
            dec(group);                       // Stop group
            result:=i+1;                      // Move one beyond group end
            State.FntLst.Add(Fnt);        // Add fontname to fontlist
          end; { true }
          false: With TXTFMT do begin         // Use fontlist
            a:=StrToIntDef(value,0);
            if font<>a then begin        // Change Textattr's to new font
              ChangeF:=TRUE;
              Written:=FALSE;
              FONT   :=a;
            end;
          end; { false }
        end else if keyword='\plain' then
         with TXTFMT do begin                 // Zero textattr's
          If bold=2 then Bold:=3;
          If Italics=2 then Italics:=3;
          If Underline=2 then Underline:=3;
          if (bold=3) or (italics=3) or (underline=3) or (Color<>0) then begin
            color:=0;
            Written:=FALSE;
            WriteChar(#0);
          end;
        end else if keyword='\fs' then with TXTFMT do begin  // Change fontsize
          case StrToIntDef(value,11) div 2 of
             1.. 5 : a:=1;
             6.. 9 : a:=2;
            10..11 : a:=3;
            12..13 : a:=4;
            14..15 : a:=5;
            else     a:=6;
          end;
          if a<>Fontsize then begin
            Written:=False;
            Fontsize:=a;
            ChangeF:=TRUE;
          end;
        end else if keyword='\tab' then begin
          WriteChar(#9);
        end else if keyword='\ul' then with TXTFMT do begin  // Set underline
          Written:=FALSE;
          if underline=0 then Underline:=1;
        end else if keyword='\b' then with TXTFMT do begin   // Set bold
          Written:=FALSE;
          if bold=0 then Bold:=1;
        end else if keyword='\i' then with TXTFMT do begin   // Set italics
          Written:=FALSE;
          if italics=0 then Italics:=1;
        end else if keyword='\cf' then with TXTFMT do begin  // Change fontcolor
          a:=StrToIntDef(value,0);
          If Color<>a then begin
            Written:=FALSE;
            ChangeF:=TRUE;
            Color:=a;
          end;
        end else if keyword='\qc' then begin     // Set paragraphformat (center)
          PARFMT.Alignment:=taCenter;
          PARFMT.Written:=FALSE;
        end else if keyword='\qr' then begin     // Set paragraphformat (right)
          PARFMT.Alignment:=taRightJustify;
          PARFMT.Written:=FALSE;
        end else if keyword='\pntext' then
         with PARFMT do begin                    // Start bullet list item
          Written   :=FALSE;
          Bullets   :=2;
          a:=group;
          repeat
            case rtf[i] of
              '{' : inc(group);
              '}' : dec(group);
            end;
            inc(i);
          until (group+1)=a;
          result:=i-1;
        end else if keyword='\fi' then with PARFMT do begin // Start bullet list
          Written   :=FALSE;
          Bullets   :=1;
          WriteChar(#0);
        end else if keyword='\pard' then
         with PARFMT do begin                // Stop paragraph / Bulletlist
          Alignment:=taLeftJustify;
          If Bullets>0 then
            Bullets:=4;
          Written:=FALSE;
        end else if keyword='\red' then begin
          col:='#'+IntToHex(StrToIntDef(value,255),2);   // Get Red color
        end else if keyword='\green' then begin
          col:=col+IntToHex(StrToIntDef(value,255),2);   // Get Green color
        end else if keyword='\blue' then begin
          col:=col+IntToHex(StrToIntDef(value,255),2);  // Get blue color
          State.ColLst.Add(col);                        // Add RGB in colorlist
        end else if keyword='\deff' then with TXTFMT do begin
          DefFont:=StrToIntDef(value,0);              // Default font
        end else if keyword='\fonttbl' then begin
          state.fnttbl:=true;                        // Create font-list
        end else if keyword='\colortbl' then begin
          state.coltbl:=true;                        // Create color-list
        end else if keyword='\deflang' then begin
          state.fnttbl:=False;                       // Update is finished
          With PARFMT do begin                       // Setup paragraphformat
            Alignment:=taLeftJustify;
            Written:=false;
            Bullets:=0;
          end;
          With TXTFMT do begin                       // Setup font-format
            Font      :=DefFont;
            Fontsize  :=3;
            Color     :=0;
            Bold      :=0;
            Italics   :=0;
            Underline :=0;
            Written   :=false;
          end;
          state.coltbl:=True;                        // Update is finished
        end; { last if then   }
      end;  { case else }
    end;
  end;  { collectcode }

  function CleanUp(s:string):string;
  // This could be done without, but - hey - it's nice
  var
    a : integer;
  begin
    // Nice up any empty <P>aragraph statements
    While pos(#13#10'<P>'#13#10'<P',s)>0 do begin
      a:=pos(#13#10'<P>'#13#10'<P',s);
      system.delete(s,a,6);
      system.insert('</P>',s,a);
    end;
    result:=s;
  end; { cleanup }

var
  crsr : integer;

begin
  try
    State.FntLst:=TstringList.Create;    // Create fontlist
    State.ColLst:=TstringList.Create;    // Create colorlist
    indx:=0;
    result:='';
    repeat
      inc(indx);
      case rtf[indx] of
        #0..#31 : ;                      // Ascii ctrl-char - ignorre
        '{' : Inc(group);
        '}' : Dec(group);
        '\' : indx:=collectcode(indx);   // Code found - the fun starts ...
        else begin
          WriteChar(rtf[indx]);         // Write char and any pending html-codes ...
          Inc(indx);                    // Speedwrite normal chars till next special one
          while (indx<length(rtf)) and
                not (rtf[indx] in ['{','}','\','<','>',#00..#31]) do begin
            result:=result+rtf[indx];
            inc(indx);
          end;
          dec(indx);
        end;

      end;
    until indx=length(rtf);
  finally
    result:=cleanup(result);      // Return the HTML document
    State.FntLst.free;
    State.ColLst.free;
  end;
end;

end.					

1:

function RtfToHtml(const rtf:string):string;