'----------------------------------------
'- 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