He encontrado este código, pero a veces falla y no funciona correctamente.
Código [Seleccionar]
'----------------------------------------
'- Name: Sam Huggill
'- Email: sam@vbsquare.com
'- Web: http://www.vbsquare.com/
'- Company: Lighthouse Internet Solutions
'- Date/Time: 14/08/99 11:31:36
'----------------------------------------
'- Notes: Colour codes text into VB code
'
'----------------------------------------
'// Thanks to Thierry Waty for his help with the colourizing
Private gsBlackKeywords As String
Private gsBlueKeyWords As String
Public oleComment As OLE_COLOR
Public oleKeyword As OLE_COLOR
Public oleText As OLE_COLOR
Public Sub ColorizeWords(rtf As Object)
oleComment = vbGreen
oleKeyword = vbBlue
oleText = vbBlack
Dim sBuffer As String
Dim i As Long
Dim nJ As Long
Dim sTmpWord As String
Dim nStartPos As Long
Dim nSelLen As Long
Dim nWordPos As Long
'
rtf.SelStart = 0
rtf.SelLength = Len(rtf.Text)
rtf.SelColor = oleText
rtf.SelFontName = "Courier New"
rtf.SelFontSize = "10"
rtf.SelUnderline = False
rtf.SelBold = False
rtf.SelItalic = False
sBuffer = rtf.Text
sTmpWord = ""
For i = 1 To Len(sBuffer)
For iLine = 1 To Len(sBuffer)
If iLine = Len(sBuffer) Then
End If
If (0 + iLine - 1) Mod Int(100 / 200 + 1) = 0 Then
DoEvents
End If
Next
Select Case Mid(sBuffer, i, 1)
Case "A" To "Z", "a" To "z", "_"
If sTmpWord = "" Then nStartPos = i
sTmpWord = sTmpWord & Mid(sBuffer, i, 1)
Case Chr(34)
nSelLen = 1
For nJ = 1 To 9999999
If Mid(sBuffer, i + 1, 1) = Chr(34) Then
i = i + 2
Exit For
Else
nSelLen = nSelLen + 1
i = i + 1
End If
Next
Case Chr(39)
rtf.SelStart = i - 1
nSelLen = 0
For nJ = 1 To 9999999
If Mid(sBuffer, i, 2) = vbCrLf Then
Exit For
Else
nSelLen = nSelLen + 1
i = i + 1
If nSelLen > Len(sBuffer) Then Exit For
End If
Next
rtf.SelLength = nSelLen
rtf.SelColor = oleComment
Case Else
If Trim(sTmpWord) <> "" Then
rtf.SelStart = nStartPos - 1
rtf.SelLength = Len(sTmpWord)
nWordPos = InStr(1, gsBlackKeywords, "*" & sTmpWord & "*", 1)
If nWordPos <> 0 Then
rtf.SelColor = oleText
rtf.SelText = Mid(gsBlackKeywords, nWordPos + 1, Len(sTmpWord))
End If
nWordPos = InStr(1, gsBlueKeyWords, "*" & sTmpWord & "*", 1)
If nWordPos <> 0 Then
rtf.SelColor = oleKeyword
rtf.SelText = Mid(gsBlueKeyWords, nWordPos + 1, Len(sTmpWord))
End If
If UCase(sTmpWord) = "'" Then
rtf.SelStart = i - 4
rtf.SelLength = 3
For nJ = 1 To 9999999
If Mid(sBuffer, i, 2) = vbCrLf Then
Exit For
Else
rtf.SelLength = rtf.SelLength + 1
i = i + 1
End If
Next
rtf.SelColor = oleComment
rtf.SelText = LCase(rtf.SelText)
End If
End If
sTmpWord = ""
End Select
Next
rtf.SelStart = Len(rtf.Text)
End Sub
Public Sub InitColorize()
gsBlackKeywords = "*Abs*Add*AddItem*AppActivate*Array*Asc*Atn*Beep*Begin*BeginProperty*ChDir*ChDrive*Choose*Chr*Clear*Collection*Command*Cos*CreateObject*CurDir*DateAdd*DateDiff*DatePart*DateSerial*DateValue*Day*DDB*DeleteSetting*Dir*DoEvents*EndProperty*Environ*EOF*Err*Exp*FileAttr*FileCopy*FileDateTime*FileLen*Fix*Format*FV*GetAllSettings*GetAttr*GetObject*GetSetting*Hex*Hide*Hour*InputBox*InStr*Int*Int*IPmt*IRR*IsArray*IsDate*IsEmpty*IsError*IsMissing*IsNull*IsNumeric*IsObject*Item*Kill*LCase*Left*Len*Load*Loc*LOF*Log*LTrim*Me*Mid*Minute*MIRR*MkDir*Month*Now*NPer*NPV*Oct*Pmt*PPmt*PV*QBColor*Raise*Randomize*Rate*Remove*RemoveItem*Reset*RGB*Right*RmDir*Rnd*RTrim*SaveSetting*Second*SendKeys*SetAttr*Sgn*Shell*Sin*Sin*SLN*Space*Sqr*Str*StrComp*StrConv*Switch*SYD*Tan*Text*Time*Time*Timer*TimeSerial*TimeValue*Trim*TypeName*UCase*Unload*Val*VarType*WeekDay*Width*Year*"
gsBlueKeyWords = "*#Const*#Else*#ElseIf*#End If*#If*Alias*Alias*And*As*Base*Binary*Boolean*Byte*ByVal*Call*Case*CBool*CByte*CCur*CDate*CDbl*CDec*CInt*CLng*Close*Compare*Const*CSng*CStr*Currency*CVar*CVErr*Decimal*Declare*DefBool*DefByte*DefCur*DefDate*DefDbl*DefDec*DefInt*DefLng*DefObj*DefSng*DefStr*DefVar*Dim*Do*Double*Each*Else*ElseIf*End*Enum*Eqv*Erase*Error*Exit*Explicit*False*For*Function*Get*Global*GoSub*GoTo*If*Imp*In*Input*Input*Integer*Is*LBound*Let*Lib*Like*Line*Lock*Long*Loop*LSet*Name*New*Next*Not*Object*On*Open*Option*Or*Output*Print*Private*Property*Public*Put*Random*Read*ReDim*Resume*Return*RSet*Seek*Select*Set*Single*Spc*Static*String*Stop*Sub*Tab*Then*Then*True*Type*UBound*Unlock*Variant*Wend*While*With*Xor*Nothing*To*"
End Sub