减小字体
增大字体·上一篇：将网页颜色值转换为VB颜色值的函数
·下一篇：JavaScript 实现旋转的立方体
VB 将HTML格式文本写入RichTextBox控件中
VB 在RichTextBox控件中使用HTML代码来设置文字样式，目前只支持 <font>、<br>、<b> 标签，可通过font标签的Color、Size、Face属性来设置文本的字体颜色、字体大小以及文字字体。
加强版：http://www.newxing.com/Code/VB/zfcl/RichText_876.html (支持 img 、span)
附件下载.rar
加强版：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
- 好的评价 如果您觉得此文章好，就请您
100%(7) 
- 差的评价 如果您觉得此文章差，就请您
0%(0) 
评论内容只代表网友观点，与本站立场无关！
评论摘要(共 0 条，得分 0 分，平均 0 分)
查看完整评论