在RTF TEXT中使用色彩

　　

*** Add VB code in a RTF control Call InitColorize Call
ColorizeWords(rtfVBCode)
*** Now your VB code in your RTF control is colorized 　
Source Code: 　
#VBIDEUtils#************************************************************
*Programmer Name : Waty Thierry
* Web Site : www.geocities.com/ResearchTriangle/6311/
* E-Mail : [email protected]
* Date : 30/10/98
* Time : 14:47
* Module Name : Colorize_Module
* Module Filename : Colorize.bas
**********************************************************************
*Comments : Colorize in black, blue, green the VB keywords
*
*
**********************************************************************
Option Explicit
Private gsBlackKeywords As String
Private gsBlueKeyWords As String
Public Sub ColorizeWords(rtf As RichTextBox)
#VBIDEUtils#************************************************************
* Programmer Name : Waty Thierry
* Web Site : www.geocities.com/ResearchTriangle/6311/
* E-Mail : [email protected]
* Date : 30/10/98
* Time : 14:47
* Module Name : Colorize_Module
* Module Filename : Colorize.bas
* Procedure Name : ColorizeWords
* Parameters :
* rtf As RichTextBox
**********************************************************************
* Comments : Colorize in black, blue, green the VB keywords
*
*
**********************************************************************
Dim sBuffer As String
Dim nI As Long
Dim nJ As Long
Dim sTmpWord As String
Dim nStartPos As Long
Dim nSelLen As Long
Dim nWordPos As Long Dim cHourglass As class_Hourglass
Set cHourglass = New class_Hourglas br> sBuffer = rtf.Text sTmpWord = "" With rtf
For nI = 1 To Len(sBuffer)
Select Case Mid(sBuffer, nI, 1)
Case "A" To "Z", "a" To "z", "_"
If sTmpWord = "" Then nStartPos = nI
sTmpWord = sTmpWord & Mid(sBuffer, nI, 1)
Case Chr(34)
nSelLen = 1
For nJ = 1 To 9999999
If Mid(sBuffer, nI + 1, 1) = Chr(34) Then nI = nI + 2
Exit For
Else
nSelLen = nSelLen + 1
nI = nI + 1
End If
Next
Case Chr(39) .
SelStart = nI - 1
nSelLen = 0
For nJ = 1 To 9999999
If Mid(sBuffer, nI, 2) = vbCrLf Then
Exit For
Else
nSelLen = nSelLen + 1
nI = nI + 1
End If
Next
.SelLength = nSelLen
.SelColor = RGB(0, 127, 0)
Case Else
If Not (Len(sTmpWord) = 0) Then
.SelStart = nStartPos - 1
.SelLength = Len(sTmpWord)
nWordPos = InStr(1, gsBlackKeywords, "*" & sTmpWord & "*", 1)
If nWordPos <> 0 Then
.SelColor = RGB(0, 0, 0)
.SelText = Mid(gsBlackKeywords, nWordPos + 1, Len(sTmpWord))
End If
nWordPos = InStr(1, gsBlueKeyWords, "*" & sTmpWord & "*", 1)
If nWordPos <> 0 Then
.SelColor = RGB(0, 0, 127)
.SelText = Mid(gsBlueKeyWords, nWordPos + 1, Len(sTmpWord))
End If
If UCase(sTmpWord) = "REM" Then
.SelStart = nI - 4
.SelLength = 3
For nJ = 1 To 9999999
If Mid(sBuffer, nI, 2) = vbCrLf Then
Exit For
Else
.SelLength = .SelLength + 1
nI = nI + 1
End If
Next
.SelColor = RGB(0, 127, 0)
.SelText = LCase(.SelText)
End If End If
sTmpWord = ""
End Select
Next
.SelStart = 0
End With
end sub
Public Sub InitColorize()
#VBIDEUtils#************************************************************
* Programmer Name : Waty Thierry
* Web Site : www.geocities.com/ResearchTriangle/6311/
* E-Mail : [email protected]
* Date : 30/10/98
* Time : 14:47
* Module Name : Colorize_Module
* Module Filename : Colorize.bas
* Procedure Name : InitColorize
* Parameters :
**********************************************************************
* Comments : Initialize the VB keywords
*
*
**********************************************************************
gsBlackKeywords ="*Abs*Add*AddItem*AppActivate*Array*Asc*Atn*"
gsBlackKeywords =gsBlackKeywords+"Beep*Begin*BeginProperty*"
gsBlackKeywords =gsBlackKeywords+"ChDir*ChDrive*Choose*"
gsBlackKeywords =gsBlackKeywords+"Chr*Clear*Collection*Command*Cos*CreateObject*"
gsBlackKeywords =gsBlackKeywords+"CurDir*DateAdd*DateDiff*DatePart*DateSerial*DateValue*"
gsBlackKeywords =gsBlackKeywords+"Day*DDB*DeleteSetting*Dir*DoEvents"
gsBlackKeywords =gsBlackKeywords+"*EndProperty*Environ*EOF*Err*"
gsBlackKeywords =gsBlackKeywords+"Exp*FileAttr*FileCopy*FileDateTime*FileLen*Fix*Format*FV
gsBlackKeywords =gsBlackKeywords+"*GetAllSettings*"GetAttr*GetObject*GetSetting*Hex*Hide*Hour*"
gsBlackKeywords =gsBlackKeywords+"InputBox*InStr*Int*Int*IPmt*IRR*IsArray"
gsBlackKeywords =gsBlackKeywords+"*IsDate*IsEmpty*IsError*"
gsBlackKeywords =gsBlackKeywords+"IsMissing*IsNull*IsNumeric*IsObject*Item*Kill"
gsBlackKeywords =gsBlackKeywords+"*LCase*Left*Len*Load*"
gsBlackKeywords =gsBlackKeywords+"Loc*LOF*Log*LTrim*Me*Mid*Minute*"
gsBlackKeywords =gsBlackKeywords+"MIRR*MkDir*Month*Now*NPer*NPV*Oct*"
gsBlackKeywords =gsBlackKeywords+"Pmt*PPmt*PV*QBColor*Raise*Randomize"
gsBlackKeywords =gsBlackKeywords+"*Rate*Remove*RemoveItem*Reset*RGB*"
gsBlackKeywords =gsBlackKeywords+"Right*RmDir*Rnd*RTrim*SaveSetting"
gsBlackKeywords =gsBlackKeywords+"*Second*SendKeys*SetAttr*Sgn*Shell*"
gsBlackKeywords =gsBlackKeywords+"Sin*Sin*SLN*Space*Sqr*Str*StrComp"
gsBlackKeywords =gsBlackKeywords+"*StrConv*Switch*SYD*Tan*Text*Time*Time*"
gsBlackKeywords =gsBlackKeywords+"Timer*TimeSerial*TimeValue*Trim*TypeName"
gsBlackKeywords =gsBlackKeywords+" *UCase*Unload*Val*VarType*WeekDay*"
gsBlackKeywords =gsBlackKeywords+"Width*Year*"
gsBlueKeyWords = "*#Const*#Else*#ElseIf*#End"
gsBlueKeyWords = gsBlueKeyWords+"If*#If*Alias*Alias*And*As*Base"
gsBlueKeyWords = gsBlueKeyWords+"*Binary*Boolean*Byte*B"
End Sub