Colorize VB Code in a RTF Control

Here are a function to colorize VB Code in a RTF control.

If you have VB Code in a RTF control, you can colorize it the same way as in VB.

You have to make a call to "InitColorize" before using it.

Sample


' *** 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           : waty.thierry@usa.net
' * 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           : waty.thierry@usa.net
   ' * 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_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()
   ' #VBIDEUtils#*************************************************
   ' * Programmer Name  : Waty Thierry
   ' * Web Site         : www.geocities.com/ResearchTriangle/6311/
   ' * E-Mail           : waty.thierry@usa.net
   ' * 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
                      *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


Comments

  • Great ! Thanx ! But...

    Posted by Legacy on 01/09/2004 12:00am

    Originally posted by: Khoi Nguyen

    How can we added this to Change event so it will colorize when why type like VB or VS ? I tried but it is a nested code and always raise a runtime error.

    Reply
  • error & question..

    Posted by Legacy on 12/27/2002 12:00am

    Originally posted by: oldbell


    I have an Error on

    'Dim cHourglass As class_Hourglass
    Set cHourglass = New class_Hourglass'

    what's the class_Hourglass ??

    ~.~

    good luck.~

    Reply
Leave a Comment
  • Your email address will not be published. All fields are required.

Top White Papers and Webcasts

  • This paper introduces IBM Java on the IBM PowerLinux 7R2 server and describes IBM's implementation of the Java platform, which includes IBM's Java Virtual Machine and development toolkit.

  • In the competitive marketplace that surrounds us today, customers shouldn't have to settle for legacy desktop or application delivery simply because they've relied on a certain vendor in the past. This white paper reviews how three customers decided to partner with VMware, and how they benefited from the latest VDI and app trends to improve the end-user experience, increase productivity, reliability and stability to deliver better SLAs - with lower cost and less time needed to manage end users.

Most Popular Programming Stories

More for Developers

Latest Developer Headlines

RSS Feeds