用户登录  |  用户注册
首 页源码下载网络学院最新源码源码排行屏蔽广告
当前位置:新兴网络 > 网络学院 > 编程开发 > Visual Basic

VB 将HTML格式文本写入RichTextBox控件中

减小字体 增大字体 作者:LinHaibo  来源:新兴网络  发布时间:2011-02-05 16:45:54
VB 在RichTextBox控件中使用HTML代码来设置文字样式,目前只支持 <font>、<br>、<b> 标签,可通过font标签的Color、Size、Face属性来设置文本的字体颜色、字体大小以及文字字体。
加强版: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, "&nbsp;", " ")
    HtmlStr = Replace(HtmlStr, "&quot;", Chr(34))
    HtmlStr = Replace(HtmlStr, "&#39;", Chr(39))
    HtmlStr = Replace(HtmlStr, "&#123;", Chr(123))
    HtmlStr = Replace(HtmlStr, "&#125;", Chr(125))
    HtmlStr = Replace(HtmlStr, "&#36;", Chr(36))
    HtmlStr = Replace(HtmlStr, "&hellip;", "…")
    HtmlStr = Replace(HtmlStr, "&lsquo;", "‘")
    HtmlStr = Replace(HtmlStr, "&rsquo;", "’")
    HtmlStr = Replace(HtmlStr, "&ldquo;", "“")
    HtmlStr = Replace(HtmlStr, "&rdquo;", "”")
    HtmlStr = Replace(HtmlStr, "&times;", "×")
    HtmlStr = Replace(HtmlStr, "&radic;", "√")
    HtmlStr = Replace(HtmlStr, "&gt;", ">")
    HtmlStr = Replace(HtmlStr, "&lt;", "<")
    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 分) 查看完整评论