Although using MSHTML as HTML editor could have been a good solution, I made something myself today: a TRichEdit to HTML converter. And I must say.. it perfectly suits my needs. It uses ComCtrls, Classes, SysUtils and Graphics so you'll have to put these into your uses clause to get this procedure to work. The way this procedure works is basically different in that it doesn't convert raw RTF codes, but uses the RichEdit control to read the mark-up states needed to compose the HTML output. This method of converting a RichEdit's contents to HTML is everything but efficient... but it works which is something I cannot say about the other converters I tried! If you have any comment on my solution, please tell me. -------------------------- procedure RichEditToHTML(ARichEdit: TRichEdit; AHTMLStrings: TStrings); function RtfFontSizeToHtmlFontSize( begin case ARtfFontSize of 0 .. 6 : Result := 0; 7 .. 8 : Result := 1; 9 ..10 : Result := 2; 11..12 : Result := 3; 13..14 : Result := 4; 15..18 : Result := 5; 19..24 : Result := 6; else Result := 7; end; end; function DelphiColorToWebColor(cons var LHexColor: string; begin LHexColor := IntToHex(ColorToRGB(AColor Result := '#' + Copy(LHexColor, 5, 2) + Copy(LHexColor, 3, 2) + Copy(LHexColor, 1, 2); end; procedure AddTagsBeforeAndAfterEvery var LIterator: Integer; LBullets: Boolean; LDivTag: string; begin // Determine the tags before and after every line of text LBullets := false; for LIterator := 0 to ATextStrings.Count - 1 do begin ARichEdit.SelStart := LongInt(ATextStrings.Objec if ARichEdit.Paragraph.Alignm LDivTag := '<DIV>' else if ARichEdit.Paragraph.Alignm LDivTag := '<DIV align="center">' else if ARichEdit.Paragraph.Alignm LDivTag := '<DIV align="right">'; if ARichEdit.Paragraph.Number begin if LBullets then begin ABeforeTextTags.Add('<LI>' if LIterator < ATextStrings.Count - 1 then AAfterTextTags.Add('</DIV> else AAfterTextTags.Add('</DIV> end else begin ABeforeTextTags.Add('<UL style="margin: 0px; padding: 0px 0px 0px 16px"><LI>' + LDivTag); if LIterator < ATextStrings.Count - 1 then AAfterTextTags.Add('</DIV> else AAfterTextTags.Add('</DIV> LBullets := true; end; end else begin if LBullets then begin AAfterTextTags[LIterator - 1] := AAfterTextTags[LIterator - 1] + '</UL>'; ABeforeTextTags.Add(LDivTa AAfterTextTags.Add('</DIV> LBullets := false; end else begin ABeforeTextTags.Add(LDivTa AAfterTextTags.Add('</DIV> end; end; end; end; procedure MergeThreeStringlists(var AStrings1, AStrings2, AStrings3, AMergedStrings: TStrings); var LIterator: Integer; begin if (AStrings1.Count <> AStrings2.Count) or (AStrings2.Count <> AStrings3.Count) then raise Exception.Create('Stringli if AStrings1.Count > 0 then begin for LIterator := 0 to AStrings1.Count - 1 do AMergedStrings.Add(AString end; end; procedure TextStringsToHTMLStrings(v function TagInAttributes(ATag: string; ARichEdit: TRichEdit): Boolean; begin if ATag = '<FONT face="' + ARichEdit.SelAttributes.Na Result := true else if ATag = '<B>' then Result := (fsBold in ARichEdit.SelAttributes.St else if ATag = '<I>' then Result := (fsItalic in ARichEdit.SelAttributes.St else if ATag = '<U>' then Result := (fsUnderline in ARichEdit.SelAttributes.St else if ATag = '<S>' then Result := (fsStrikeOut in ARichEdit.SelAttributes.St else Result := false; end; procedure OpenTag(ATag: string; var AHTMLString: string; var AOpenTags: TStrings); begin AHTMLString := AHTMLString + ATag; AOpenTags.Add(ATag); end; procedure CloseTag(ATag: string; var AHTMLString: string; var AOpenTags: TStrings); var LCloseTag: string; begin LCloseTag := '</' + Copy(ATag, 2, MaxInt); if pos(' ', LCloseTag) > 0 then Delete(LCloseTag, pos(' ', LCloseTag), Length(LCloseTag) - pos(' ', LCloseTag)); AHTMLString := AHTMLString + LCloseTag; if AOpenTags.IndexOf(ATag) >= 0 then AOpenTags.Delete(AOpenTags end; var LOpenTags: TStrings; LIterator1: Integer; LTextString: string; LHTMLString: string; LIterator2: Integer; LIterator3: Integer; LIterator4: Integer; LCurrentChar: Char; begin // Initialise the variables LOpenTags := TStringList.Create; try for LIterator1 := 0 to ATextStrings.Count - 1 do begin LTextString := ATextStrings[LIterator1]; LHTMLString := ''; LOpenTags.Clear; for LIterator2 := 1 to Length(LTextString) do begin // Read the current character LCurrentChar := LTextString[LIterator2]; // Set the cursor to the current position so we can read the // textattributes and paraattributes of the current character ARichEdit.SelStart := LongInt(ATextStrings.Objec // Close html tags // Determine till what level the tags can be kept open if LOpenTags.Count > 0 then begin // Initialize the counter for the level of tags we have to remain open LIterator3 := 0; // find out which tags may remain open while (LIterator3 < LOpenTags.Count) do begin if TagInAttributes(LOpenTags[ Inc(LIterator3) else Break; end; // If there are tags that may not remain open... close them in reverse // order. if LIterator3 < LOpenTags.Count then begin for LIterator4 := LOpenTags.Count - 1 downto LIterator3 do CloseTag(LOpenTags[LIterat end; end; // Open html tags if LOpenTags.IndexOf('<FONT face="' + ARichEdit.SelAttributes.Na OpenTag('<FONT face="' + ARichEdit.SelAttributes.Na if (fsBold in ARichEdit.SelAttributes.St if LOpenTags.IndexOf('<B>') = -1 then OpenTag('<B>', LHTMLString, LOpenTags); if (fsItalic in ARichEdit.SelAttributes.St if LOpenTags.IndexOf('<I>') = -1 then OpenTag('<I>', LHTMLString, LOpenTags); if (fsUnderline in ARichEdit.SelAttributes.St if LOpenTags.IndexOf('<U>') = -1 then OpenTag('<U>', LHTMLString, LOpenTags); if (fsStrikeOut in ARichEdit.SelAttributes.St if LOpenTags.IndexOf('<S>') = -1 then OpenTag('<S>', LHTMLString, LOpenTags); // Add currentchar if LCurrentChar = ' ' then begin if LIterator2 > 1 then begin if LTextString[LIterator2 - 1] = ' ' then LHTMLString := LHTMLString + ' ' else LHTMLString := LHTMLString + LCurrentChar; end else LHTMLString := LHTMLString + LCurrentChar; end else if LCurrentChar = '"' then LHTMLString := LHTMLString + '"' else if LCurrentChar = '&' then LHTMLString := LHTMLString + '&' else if LCurrentChar = '<' then LHTMLString := LHTMLString + '<' else if LCurrentChar = '>' then LHTMLString := LHTMLString + '>' else LHTMLString := LHTMLString + LCurrentChar; end; // Close all tags in reverse order. if LOpenTags.Count > 0 then begin for LIterator3 := LOpenTags.Count - 1 downto 0 do CloseTag(LOpenTags[LIterat end; if Trim(LHTMLString) = '' then LHTMLString := LHTMLString + ' '; ATextStrings[LIterator1] := LHTMLString; end; finally LOpenTags.Free; end; end; var LBeforeTextTags: TStrings; LTextStrings: TStrings; LAfterTextTags: TStrings; begin LBeforeTextTags := TStringList.Create; try LTextStrings := TStringList.Create; try LAfterTextTags := TStringList.Create; try ARichEdit.Lines.BeginUpdat // Clear the output AHTMLStrings.Clear; // Split the text into separate strings and keep references to the // startposition of each line in the original textstring StringToStringListWithLine // Continue conversion only if there is at least one line if LTextStrings.Count > 0 then begin // Add tags to open and close each line into the seperate // stringlists (LBeforeTextTags and LAfterTextTags). AddTagsBeforeAndAfterEvery TextStringsToHTMLStrings(L // Open the HTML document: AHTMLStrings.Add('<!DOCTYP AHTMLStrings.Add('<HTML><H // Merge the opentags, text and closetags into one stringlist (AHTMLStrings) MergeThreeStringlists(LBef // Close the HTML document: AHTMLStrings.Add('</BODY>< end; finally ARichEdit.Lines.EndUpdate; finally LAfterTextTags.Free; end; finally LTextStrings.Free; end; finally LBeforeTextTags.Free; end; end; |
|
来自: quasiceo > 《rtf2html》