程序代码：

Public Function 彩色化(cs As String) As String

Dim i As Long, j As String
Dim js() As String
j = cs & vbCrLf
j = Replace(j, "\", "\\")           '单\换成双\\
js = Split(cs, vbCrLf)

If UBound(js) > 1000 Then
    If MsgBox("脚本非常长，进行命令标记需要很长的时间，是否继续？", vbInformation + vbOKCancel + vbDefaultButton2, 标题) = vbCancel Then
        彩色化 = cs
        Exit Function
    End If
End If

For i = 0 To UBound(js)
    If Left(Trim(js(i)), 1) = ";" Then
        j = Replace(j, js(i), "\cf1" & js(i) & "\cf0")
    'ElseIf Left(Trim(js(i)), 1) = "#" Then
    '    j = Replace(j, js(i), "\cf2" & js(i) & "\cf0")
    ElseIf Left(Trim(js(i)), 2) = "[~" Then
        j = Replace(j, Mid(js(i), 2, Len(js(i)) - 2), "\cf4" & Mid(js(i), 2, Len(js(i)) - 2) & "\cf0")
    End If
Next i

'j = Replace(j, js(i), "\cf1" & js(i) & "\cf0")
For i = 0 To UBound(命令)
    With 命令(i)
    If Len(.命令) > 2 Then
    Select Case Left(.命令, 1)
        Case "#"
            j = Replace(j, .命令, "\cf2 " & .命令 & "\cf0 ")
        Case "\"

        Case "."

        Case Else
            If InStr(1, j, .命令 & " ") > 0 Then
                j = Replace(j, .命令 & " ", "\cf3 " & .命令 & " \cf0 ", , , vbTextCompare)
            End If
    End Select
    End If
    End With
Next i

    Call 取标记(txtbox.Text)

On Error GoTo err1:
For i = 0 To UBound(标记)
    With 标记(i)
            j = Replace(j, "[@" & .标记名称 & "]", "[\cf4 @" & .标记名称 & "\cf0 ]")
            j = Replace(j, " @" & .标记名称 & " ", " \cf4 @" & .标记名称 & " \cf0 ")
            j = Replace(j, "@" & .标记名称 & ">", "\cf4 @" & .标记名称 & "\cf0 >")
    End With
Next i

err2:
On Error GoTo 0
    j = Replace(j, vbCrLf, vbCrLf & "\par ")        '换回车符
    j = Replace(j, "\par \cf", "\par\cf")         '换掉标记中间的空格
   
    j = "\viewkind4\uc1\pard\lang2052\f0\fs21" & j     '加头,倒次序加,显示头,颜色表,RTF头
    j = "{\colortbl ;\red0\green128\blue64;\red128\green0\blue64;\red0\green0\blue128;\red128\green0\blue255;}" & vbCrLf & j
    j = "{\rtf1\ansi\ansicpg936\deff0\deflang1033\deflangfe2052{\fonttbl{\f0\fnil\fcharset134 \'cb\'ce\'cc\'e5;}}" & vbCrLf & j
    j = j & "}"                                     '加结尾
   
    彩色化 = j
    Exit Function
err1:
    GoTo err2:
End Function

程序代码：

Public Sub 着色(obj As RichTextBox)

Const RTF头 = "{\rtf1\ansi\ansicpg936\deff0\deflang1033\deflangfe2052{\fonttbl{\f0\fmodern\fprq6\fcharset134 \'cb\'ce\'cc\'e5;}}"   '宋体
Const 颜色头 = "{\colortbl "
Const 字号 = "\viewkind4\uc1\pard\lang2052\f0\fs24"

Dim s As String
s = LCase(obj.Text)

Dim 颜色表 As String


Dim i As Long
Dim j As Long


For i = 0 To UBound(colorset)
    颜色表 = 颜色表 & ";" & colorset(i).Color

    For j = 0 To UBound(colorset(i).list)
        If Len(Trim(colorset(i).list(j))) > 0 Then      '关键字不为空,那么就着色
            s = Replace(s, " " & colorset(i).list(j) & " ", "\cf" & i + 1 & " " & colorset(i).list(j) & "\cf0 ")
            s = Replace(s, " " & colorset(i).list(j) & vbCrLf, "\cf" & i + 1 & " " & colorset(i).list(j) & "\cf0" & vbCrLf)
            s = Replace(s, vbCrLf & colorset(i).list(j) & " ", vbCrLf & "\cf" & i + 1 & " " & colorset(i).list(j) & "\cf0 ")
            s = Replace(s, vbCrLf & colorset(i).list(j) & vbCrLf, vbCrLf & "\cf" & i + 1 & " " & colorset(i).list(j) & "\cf0" & vbCrLf, , 1)
        End If
    Next j
Next i
    s = Replace(s, vbCrLf, "\par" & vbCrLf)
颜色表 = 颜色头 & 颜色表 & ";}"
s = RTF头 & vbCrLf & 颜色表 & 字号 & s & "}"
obj.TextRTF = s

End Sub

程序代码：

Public Type 结构类型
    Color  As String
    list() As String
End Type

Public colorset() As 结构类型

Const setfile = "data.txt"

Public Sub 读颜色设置()

Const 头 = "[color="

Dim fj As Long
fj = FreeFile

Dim i As Long
Dim j As Long
Dim t As String
Dim m As String
Dim byt() As String

'读设置总块数
i = -1
Open setfile For Input As fj
Do While Not EOF(fj)
    Line Input #fj, t
    t = Trim(LCase(t))
    If InStr(1, t, 头) = 1 Then         '需要计数
        i = i + 1
    End If
Loop
Close fj

ReDim colorset(i)

'读每块设置总行数
i = -1: j = -1
Open setfile For Input As fj
Do While Not EOF(fj)
    Line Input #fj, t
    t = Trim(LCase(t))
    If InStr(1, t, 头) = 1 Then         '需要计数
        If i >= 0 Then
            ReDim colorset(i).list(j)
            j = -1
            byt = Split(m, " ")
            colorset(i).Color = "\red" & byt(0) & "\green" & byt(1) & "\blue" & byt(2)
        End If
        i = i + 1
        m = Mid(t, Len(头) + 1)
        m = Left(m, Len(m) - 1)
    Else
        j = j + 1
    End If
Loop
    ReDim colorset(i).list(j)
    byt = Split(m, " ")
    colorset(i).Color = "\red" & byt(0) & "\green" & byt(1) & "\blue" & byt(2)
Close fj

'读每行内容
i = -1: j = -1
Open setfile For Input As fj
Do While Not EOF(fj)
    Line Input #fj, t
    t = Trim(LCase(t))
    If InStr(1, t, 头) = 1 Then         '需要计数
        If i >= 0 Then
            j = -1
        End If
        i = i + 1
    Else
        j = j + 1
        colorset(i).list(j) = Trim(LCase(t))
    End If
Loop
Close fj
End Sub

程序代码：

Private Sub Command1_Click()
    Call 着色(RichTextBox1)
End Sub

Private Sub Form_Load()
Call 读颜色设置
End Sub