加强版：http://www.newxing.com/Code/VB/zfcl/RichText_876.html (支持 img 、span)
- HTML code运行代码复制代码编辑
<font color=red> <font color="#5800FA"><b>新兴网络</b></font> <br> http://www.<b><font color=#C6C600 size=20>newxing</font></b>.com <br/> <font color=#00A1FF>AA <font color=#ee00ff>BB <b> <font color=#459C00>CC</font> <font color=red>DD</font> </b> BB </font> AA </font> <br> <font face="微软雅黑" size=18>abcdefg</font> <br /> <font face="楷体"size=18>abcdefg</font> </font> <br> abcdefg
以下是模块代码：
- VBScript code复制代码
Option Explicit '************************************************************************* '**作 者：新兴网络 '**原 文：http://www.newxing.com/Tech/Program/VisualBasic/RichText_661.html '**如果需要转载，请保留作者信息谢谢 '************************************************************************* Public Sub setRT(RichText As RichTextBox, StrText As String) Call ParseFont(RichText, StrText, StrText) End Sub Private Sub ParseBold(RichText As RichTextBox, StrText As String, strValue As String, FirstIndex As Integer, Optional FontColor As Long = vbBlack, Optional FontSize As Integer = 9, Optional FontName As String = "宋体") Dim Bold As Boolean If Not RegExpTest(strValue, "(.*?)<b>(.*?(?:(?:<b>.*?(?:<b>.*?(?:<b>.*?</b>.*?)*?</b>.*?)*?</b>).*?)*?)</b>([^<]*)") Then Bold = CheckIsBold(StrText, FirstIndex, Len(strValue)) Call setRTStyle(RichText, HTMLDecode(RegExReplace(RegExReplace(strValue, "<br *[\/]{0,1}>", vbCrLf), "<[\/]{0,1}.+?>", "")), FontColor, Bold, FontSize, FontName) Exit Sub End If Dim Regex As Object, Matches As Object, Match As Object Set Regex = CreateObject("VBScript.RegExp") Regex.IgnoreCase = True Regex.Global = True Regex.Pattern = "(.*?)<b>(.*?(?:(?:<b>.*?(?:<b>.*?(?:<b>.*?</b>.*?)*?</b>.*?)*?</b>).*?)*?)</b>([^<]*)" Set Matches = Regex.Execute(strValue) For Each Match In Matches If Match.SubMatches(0) <> "" Then Bold = CheckIsBold(StrText, FirstIndex + InStr(Match.Value, Match.SubMatches(0)) - 1, Len(Match.SubMatches(0))) Call setRTStyle(RichText, HTMLDecode(RegExReplace(RegExReplace(Match.SubMatches(0), "<br *[\/]{0,1}>", vbCrLf), "<[\/]{0,1}.+?>", "")), FontColor, Bold, FontSize, FontName) End If If Match.SubMatches(1) <> "" Then Call setRTStyle(RichText, HTMLDecode(RegExReplace(RegExReplace(Match.SubMatches(1), "<br *[\/]{0,1}>", vbCrLf), "<[\/]{0,1}.+?>", "")), FontColor, True, FontSize, FontName) End If If Match.SubMatches(2) <> "" Then Bold = CheckIsBold(StrText, FirstIndex + InStr(Match.Value, Match.SubMatches(2)), Len(Match.SubMatches(2))) Call setRTStyle(RichText, HTMLDecode(RegExReplace(RegExReplace(Match.SubMatches(2), "<br *[\/]{0,1}>", vbCrLf), "<[\/]{0,1}.+?>", "")), FontColor, Bold, FontSize, FontName) End If Next Set Regex = Nothing Set Matches = Nothing Set Match = Nothing End Sub Private Function CheckIsBold(StrText As String, FirstIndex As Integer, Length As Integer) As Boolean Dim Regex As Object, Matches As Object, Match As Object Set Regex = CreateObject("VBScript.RegExp") Regex.IgnoreCase = True Regex.Global = True Regex.Pattern = "<b>.*?(?:(?:<b>.*?(?:<b>.*?(?:<b>.*?</b>.*?)*?</b>.*?)*?</b>).*?)*?</b>" Set Matches = Regex.Execute(StrText) For Each Match In Matches If FirstIndex >= Match.FirstIndex And (FirstIndex + Length) <= (Match.FirstIndex + Match.Length) Then CheckIsBold = True Exit For End If Next Set Regex = Nothing Set Matches = Nothing Set Match = Nothing End Function Private Sub ParseFont(RichText As RichTextBox, StrText As String, BackupStrText As String, Optional FirstIndex As Integer = 0, Optional ParentColor As Long = vbBlack, Optional ParentFontSize As Integer = 9, Optional ParentFontName As String = "宋体") StrText = Replace$(StrText, vbCrLf, "") StrText = RegExReplace(StrText, " *<(?![\/]{0,1}(?:font|br|b)).*?> *", "") StrText = RegExReplace(StrText, "[\t ]+", " ") BackupStrText = Replace$(BackupStrText, vbCrLf, "") BackupStrText = RegExReplace(BackupStrText, " *<(?![\/]{0,1}(?:font|br|b)).*?> *", "") BackupStrText = RegExReplace(BackupStrText, "[\t ]+", " ") If Not RegExpTest(StrText, "(.*?)(<font *.*?>)(.*?)((?:(<font *.*?>.*?(?:<font *.*?>.*?(?:<font *.*?>.*?</font>.*?)*?</font>.*?)*?</font>)(.*?))*?)</font>((?:[^<]*(?:<br *[\/]{0,1}>|<b>|</b>)*[^<]*)*)") Then Call ParseBold(RichText, StrText, BackupStrText, 0) Exit Sub End If Dim Regex As Object, Matches As Object, Match As Object Dim FontColor As Long, IsBold As Boolean, FontSize As Integer, FontName As String Set Regex = CreateObject("VBScript.RegExp") Regex.IgnoreCase = True Regex.Global = True Regex.Pattern = "(.*?)(<font *.*?>)(.*?)((?:(<font *.*?>.*?(?:<font *.*?>.*?(?:<font *.*?>.*?</font>.*?)*?</font>.*?)*?</font>)(.*?))*?)</font>((?:[^<]*(?:<br *[\/]{0,1}>|<b>|</b>)*[^<]*)*)" Set Matches = Regex.Execute(StrText) For Each Match In Matches FontColor = vbBlack FontSize = 9 FontName = "宋体" If Match.SubMatches(0) <> "" Then Call ParseBold(RichText, BackupStrText, Match.SubMatches(0), FirstIndex + Match.FirstIndex + InStr(Match.Value, Match.SubMatches(0)) - 1, ParentColor, ParentFontSize, ParentFontName) End If Dim Regex2 As Object, Matches2 As Object, Match2 As Object Set Regex2 = CreateObject("VBScript.RegExp") Regex2.IgnoreCase = True Regex2.Global = True Regex2.Pattern = "[ ""](?:(\w+) *?= *(?:""|)((?:rgb *\(.+?\))|(?:[#0-9a-zA-Z\u4e00-\u9fa5]+)))*" Set Matches2 = Regex2.Execute(Match.SubMatches(1)) For Each Match2 In Matches2 Select Case VBA.LCase(Match2.SubMatches(0)) Case "color" FontColor = WebColorToVBColor(Match2.SubMatches(1)) Case "size" FontSize = Val(Match2.SubMatches(1)) Case "face" FontName = Match2.SubMatches(1) End Select Next Set Regex2 = Nothing Set Matches2 = Nothing Set Match2 = Nothing If FontColor = vbBlack Then FontColor = ParentColor If FontSize = 9 Then FontSize = ParentFontSize If FontName = "宋体" Then FontName = ParentFontName If Match.SubMatches(2) <> "" Then Call ParseBold(RichText, BackupStrText, Match.SubMatches(2), FirstIndex + Match.FirstIndex + InStr(Match.Value, Match.SubMatches(2)) - 1, FontColor, FontSize, FontName) End If If Match.SubMatches(3) <> Match.SubMatches(4) & Match.SubMatches(5) Then Dim intR As Integer, strSubM3 As String intR = InStrRev(Match.SubMatches(3), Match.SubMatches(4) & Match.SubMatches(5)) strSubM3 = Left(Match.SubMatches(3), intR - 1) Call ParseFont(RichText, strSubM3, BackupStrText, FirstIndex + Match.FirstIndex + InStr(Match.Value, Match.SubMatches(3)) - 1, FontColor, FontSize, FontName) End If If Match.SubMatches(4) <> "" Then Call ParseFont(RichText, Match.SubMatches(4), BackupStrText, FirstIndex + Match.FirstIndex + InStr(Match.Value, Match.SubMatches(4)) - 1, FontColor, FontSize, FontName) End If If Match.SubMatches(5) <> "" Then Call ParseBold(RichText, BackupStrText, Match.SubMatches(5), FirstIndex + Match.FirstIndex + InStr(Match.Value, Match.SubMatches(5)) - 1, FontColor, FontSize, FontName) End If If Match.SubMatches(6) <> "" Then Call ParseBold(RichText, BackupStrText, Match.SubMatches(6), FirstIndex + Match.FirstIndex + InStr(Match.Value, Match.SubMatches(6)) - 1, ParentColor, ParentFontSize, ParentFontName) End If Next Set Regex = Nothing Set Matches = Nothing Set Match = Nothing End Sub Private Sub setRTStyle(RichText As RichTextBox, StrText As String, Optional FontColor As Long = vbBlack, Optional IsBold As Boolean = False, Optional Size As Integer = 9, Optional FontName As String = "宋体") RichText.SelStart = Len(RichText.Text) RichText.SelColor = FontColor RichText.SelBold = IsBold RichText.SelFontSize = Size RichText.SelFontName = FontName RichText.SelText = StrText End Sub Private Function WebColorToVBColor(WebColor As String) As Long Dim strhex As String, R As Double, G As Double, B As Double If RegExpTest(WebColor, "rgb *\(.+?\)") Then Dim sRight As String, RGBArr() As String, i As Integer sRight = Right$(WebColor, Len(WebColor) - InStr(WebColor, "(")) RGBArr = Split(Left$(sRight, Len(sRight) - 1), ",") For i = 0 To UBound(RGBArr) Select Case i Case 0 R = Val(RGBArr(i)) Case 1 G = Val(RGBArr(i)) Case 2 B = Val(RGBArr(i)) End Select Next WebColorToVBColor = RGB(R, G, B) Exit Function ElseIf InStr(WebColor, "#") = 0 Then Select Case VBA.LCase(WebColor) Case "black": WebColor = "#000000" Case "green": WebColor = "#008000" Case "silver": WebColor = "#c0c0c0" Case "lime": WebColor = "#00ff00" Case "gray": WebColor = "#808080" Case "olive": WebColor = "#808000" Case "white": WebColor = "#ffffff" Case "yellow": WebColor = "#ffff00" Case "maroon": WebColor = "#800000" Case "navy": WebColor = "#000080" Case "red": WebColor = "#ff0000" Case "blue": WebColor = "#0000ff" Case "purple": WebColor = "#800080" Case "teal": WebColor = "#008080" Case "fuchsia": WebColor = "#ff00ff" Case "aqua": WebColor = "#00ffff" Case Else: WebColor = "#000000" End Select End If strhex = Trim$(Replace$(WebColor, "#", "")) R = CHex(Left$(strhex, 2)) G = CHex(Right$(Left$(strhex, 4), 2)) B = CHex(Right$(strhex, 2)) WebColorToVBColor = RGB(R, G, B) End Function Private Function CHex(H) As Double Dim Hv, Dv, D, m H = UCase$(H) For m = 1 To Len(H) Hv = Left$(Right$(H, m), 1) Select Case Hv Case "A": Dv = 10 Case "B": Dv = 11 Case "C": Dv = 12 Case "D": Dv = 13 Case "E": Dv = 14 Case "F": Dv = 15 Case Else: Dv = Hv End Select D = D + (Dv * (16 ^ (m - 1))) Next CHex = D End Function Private Function HTMLDecode(HtmlStr) As String HtmlStr = Replace(HtmlStr, " ", " ") HtmlStr = Replace(HtmlStr, """, Chr(34)) HtmlStr = Replace(HtmlStr, "'", Chr(39)) HtmlStr = Replace(HtmlStr, "{", Chr(123)) HtmlStr = Replace(HtmlStr, "}", Chr(125)) HtmlStr = Replace(HtmlStr, "$", Chr(36)) HtmlStr = Replace(HtmlStr, "…", "…") HtmlStr = Replace(HtmlStr, "‘", "‘") HtmlStr = Replace(HtmlStr, "’", "’") HtmlStr = Replace(HtmlStr, "“", "“") HtmlStr = Replace(HtmlStr, "”", "”") HtmlStr = Replace(HtmlStr, "×", "×") HtmlStr = Replace(HtmlStr, "√", "√") HtmlStr = Replace(HtmlStr, ">", ">") HtmlStr = Replace(HtmlStr, "<", "<") HTMLDecode = HtmlStr End Function Private Function RegExpTest(StrText, Pattern) As Boolean Dim Regex As Object Set Regex = CreateObject("VBScript.RegExp") Regex.Pattern = Pattern Regex.IgnoreCase = True Regex.Global = True RegExpTest = Regex.Test(StrText) Set Regex = Nothing End Function Private Function RegExReplace(Str, Pattern, Str2) As String Dim Regex As Object Set Regex = CreateObject("VBScript.RegExp") Regex.IgnoreCase = True Regex.Global = True Regex.Pattern = Pattern RegExReplace = Regex.Replace(Str, Str2) Set Regex = Nothing End Function
调用方法：
Private Sub Command1_Click() RichTextBox1.Text = "" Call setRT(RichTextBox1, "文本内容") End Sub
附件下载.rar