Óû§µÇ¼  |  Óû§×¢²á
Ê× Ò³ ©ª Ô´ÂëÏÂÔØ ©ª ÍøÂçѧԺ ©ª ×îÐÂÔ´Âë ©ª Ô´ÂëÅÅÐÐ ©ª ÆÁ±Î¹ã¸æ
µ±Ç°Î»ÖãºÐÂÐËÍøÂç > ÍøÂçѧԺ > ±à³Ì¿ª·¢ > 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 ·Ö) ²é¿´ÍêÕûÆÀÂÛ