推荐订阅源

Public Sub HighLight(RTB As RichTextBox, lColor As Long)
'add new color to color table
'add tags \highlight# and \highlight0
'where # is new color number
Dim iPos As Long
Dim strRTF As String
Dim bkColor As Integer

    With RTB
        iPos = .SelStart
        'bracket selection
        .SelText = Chr(&H9D) & .SelText & Chr(&H81)
        strRTF = RTB.TextRTF
'add new color
        bkColor = AddColorToTable(strRTF, lColor)
'add highlighting
         strRTF = Replace(strRTF, "\'9d", "\up1\highlight" & CStr(bkColor) & "")
         strRTF = Replace(strRTF, "\'81", "\highlight0\up0 ")

         .TextRTF = strRTF
        .SelStart = iPos
       End With

End Sub

Function AddColorToTable(strRTF As String, lColor As Long) As Integer
Dim iPos As Long, jpos As Long

Dim ctbl As String
Dim tagColors
Dim nColors As Integer
Dim tagNew As String
Dim i As Integer
Dim iLen As Integer
Dim split1 As String
Dim split2 As String

    'make new color into tag
    tagNew = "\red" & CStr(lColor And &HFF) & _
        "\green" & CStr(Int(lColor / &H100) And &HFF) & _
        "\blue" & CStr(Int(lColor / &H10000))
    
    'find colortable
    iPos = InStr(strRTF, "{\colortbl")
    
    If iPos > 0 Then 'if table already exists
        jpos = InStr(iPos, strRTF, ";}")
        'color table
        ctbl = Mid(strRTF, iPos + 12, jpos - iPos - 12)
        'array of color tags
        tagColors = Split(ctbl, ";")
        nColors = UBound(tagColors) + 2
        'see if our color already exists in table
        For i = 0 To UBound(tagColors)
            If tagColors(i) = tagNew Then
                AddColorToTable = i + 1
                Exit Function
            End If
        Next i
'{\fonttbl{\f0\fnil\fcharset0 Verdana;}}
'{\colortbl ;\red0\green0\blue0;\red128\green0\blue255;}
        
        split1 = Left(strRTF, jpos)
        split2 = Mid(strRTF, jpos + 1)
        strRTF = split1 & tagNew & ";" & split2
        AddColorToTable = nColors
    
    Else
        'color table doesn't exists, let's make one
        iPos = InStr(strRTF, "{\fonttbl") 'beginning of font table
        jpos = InStr(iPos, strRTF, ";}}") + 2 'end of font table
        split1 = Left(strRTF, jpos)
        split2 = Mid(strRTF, jpos + 1)
        strRTF = split1 & "{\colortbl ;" & tagNew & ";}" & split2
        AddColorToTable = 1
    End If

End Function