home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / himetr1r / modcolou.bas < prev    next >
Encoding:
BASIC Source File  |  1999-08-14  |  6.1 KB  |  145 lines
  1. Attribute VB_Name = "modColourize"
  2. '----------------------------------------
  3. '- Name: Sam Huggill
  4. '- Email: sam@vbsquare.com
  5. '- Web: http://www.vbsquare.com/
  6. '- Company: Lighthouse Internet Solutions
  7. '- Date/Time: 14/08/99 11:31:36
  8. '----------------------------------------
  9. '- Notes:   Colour codes text into VB code
  10. '
  11. '----------------------------------------
  12.  
  13. '// Thanks to Thierry Waty for his help with the colourizing
  14.  
  15. Private gsBlackKeywords    As String
  16. Private gsBlueKeyWords     As String
  17. Public oleComment As OLE_COLOR
  18. Public oleKeyword As OLE_COLOR
  19. Public oleText As OLE_COLOR
  20.  
  21. Public Sub ColorizeWords(rtf As RichTextBox)
  22.  
  23.     Dim sBuffer    As String
  24.     Dim i          As Long
  25.     Dim nJ         As Long
  26.     Dim sTmpWord   As String
  27.     Dim nStartPos  As Long
  28.     Dim nSelLen    As Long
  29.     Dim nWordPos   As Long
  30.  
  31.     Dim cHourGlass    As CWaitCursor
  32.     Set cHourGlass = New CWaitCursor
  33.  
  34.     cHourGlass.SetCursor vbHourglass
  35.     '
  36.     frmMain.tbrMain.ButtonEnabled("COLOUR") = False
  37.  
  38.     rtf.SelStart = 0
  39.     rtf.SelLength = Len(rtf.Text)
  40.     rtf.SelColor = oleText
  41.     rtf.SelFontName = "Courier New"
  42.     rtf.SelFontSize = "10"
  43.     rtf.SelUnderline = False
  44.     rtf.SelBold = False
  45.     rtf.SelItalic = False
  46.  
  47.     sBuffer = rtf.Text
  48.     sTmpWord = ""
  49.     For i = 1 To Len(sBuffer)
  50.         For iLine = 1 To Len(sBuffer)
  51.             If iLine = Len(sBuffer) Then
  52.                 frmMain.pgb.Value = frmMain.pgb.Value + (100 - frmMain.pgb.Value)
  53.             End If
  54.  
  55.             If frmMain.pgb.Value = 100 Then Exit For
  56.             If (0 + iLine - 1) Mod Int(100 / 200 + 1) = 0 Then
  57.                 frmMain.pgb.Value = (0 + iLine - 1)
  58.                 frmMain.stbBar.Panels(1).Text = "Colourizing.."
  59.                 DoEvents
  60.             End If
  61.  
  62.         Next
  63.         Select Case mID(sBuffer, i, 1)
  64.             Case "A" To "Z", "a" To "z", "_"
  65.                 If sTmpWord = "" Then nStartPos = i
  66.                 sTmpWord = sTmpWord & mID(sBuffer, i, 1)
  67.             Case Chr(34)
  68.                 nSelLen = 1
  69.                 For nJ = 1 To 9999999
  70.                     If mID(sBuffer, i + 1, 1) = Chr(34) Then
  71.                         i = i + 2
  72.                         Exit For
  73.                     Else
  74.                         nSelLen = nSelLen + 1
  75.                         i = i + 1
  76.                     End If
  77.                 Next
  78.             Case Chr(39)
  79.                 rtf.SelStart = i - 1
  80.                 nSelLen = 0
  81.                 For nJ = 1 To 9999999
  82.                     If mID(sBuffer, i, 2) = vbCrLf Then
  83.                         Exit For
  84.                     Else
  85.                         nSelLen = nSelLen + 1
  86.                         i = i + 1
  87.                         If nSelLen > Len(sBuffer) Then Exit For
  88.                     End If
  89.                 Next
  90.  
  91.                 rtf.SelLength = nSelLen
  92.                 rtf.SelColor = oleComment
  93.  
  94.             Case Else
  95.                 If Trim(sTmpWord) <> "" Then
  96.                     rtf.SelStart = nStartPos - 1
  97.                     rtf.SelLength = Len(sTmpWord)
  98.                     nWordPos = InStr(1, gsBlackKeywords, "*" & sTmpWord & "*", 1)
  99.                     If nWordPos <> 0 Then
  100.                         rtf.SelColor = oleText
  101.                         rtf.SelText = mID(gsBlackKeywords, nWordPos + 1, Len(sTmpWord))
  102.                     End If
  103.                     nWordPos = InStr(1, gsBlueKeyWords, "*" & sTmpWord & "*", 1)
  104.                     If nWordPos <> 0 Then
  105.                         rtf.SelColor = oleKeyword
  106.                         rtf.SelText = mID(gsBlueKeyWords, nWordPos + 1, Len(sTmpWord))
  107.                     End If
  108.                     If UCase(sTmpWord) = "REM" Then
  109.                         rtf.SelStart = i - 4
  110.                         rtf.SelLength = 3
  111.                         For nJ = 1 To 9999999
  112.                             If mID(sBuffer, i, 2) = vbCrLf Then
  113.                                 Exit For
  114.                             Else
  115.                                 rtf.SelLength = rtf.SelLength + 1
  116.                                 i = i + 1
  117.                             End If
  118.                         Next
  119.  
  120.                         rtf.SelColor = oleComment
  121.                         rtf.SelText = LCase(rtf.SelText)
  122.                     End If
  123.                 End If
  124.  
  125.                 sTmpWord = ""
  126.         End Select
  127.  
  128.  
  129.     Next
  130.     rtf.SelStart = 0
  131.     frmMain.pgb.Value = 0
  132.     frmMain.stbBar.Panels(1).Text = ""
  133.     frmMain.tbrMain.ButtonEnabled("COLOUR") = True
  134.  
  135. End Sub
  136.  
  137. Public Sub InitColorize()
  138.  
  139.     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*"
  140.     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*"
  141.  
  142. End Sub
  143.  
  144.  
  145.