Colorize VB Code in a RTF Control


Option Explicit

Private gsBlackKeywords    As String
Private gsBlueKeyWords     As String

Public Sub ColorizeWords(rtf As RichTextBox)


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_Hourglass

   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()


 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



Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s