With this code you can highlight VB code. keywords, sub names, and function names are included as well as comments.
Add this file at the same path as the VB project called Functions.txt.
UBound
LBound
CInt
CStr
CBool
CByte
CCur
CDate
CDbl
CInt
CLng
CSng
CStr
CVar
CVErr
Also under the same path add a file called Keywords.txt with this in it. It includes subs and keywords:
Seek
Input
Error
Lock
Unlock
Line Input
Call
Erase
Put
Get
Empty
Step
Wend
While
Until
Let
Null
Each
To
True
False
Like
Is
Mod
Imp
Eqv
On Error
Set
Nothing
Declare
Lib
ByVal
ByRef
Dim
ReDim
Preserve
Const
Static
If
Then
End If
ElseIf
Else
GoTo
Open
Close
Input
Output
Binary
Random
Access
Read
Write
ReadWrite
And
Or
Xor
Not
Private
Public
Sub
Function
Property
Case
Do
For
End
With
Select
Exit Function
Exit Sub
Exit Do
Exit For
Exit Property
End Sub
End Function
End Property
End Type
End With
End Select
Type
Enum
Option Explicit
Option Base
Dim
As
String
Integer
Long
Double
Single
Date
Boolean
Byte
Currency
String
Variant
New
Object
OLE_CANCELBOOL
OLE_COLOR
OLE_HANDLE
OLE_OPTEXCLUSIVE
OLE_TRISTATE
Then, just use the function VBCodeSyntaxHighlight on a RTB and you can print out colourful code, put it on a web page, or whatever you want.
Private Function LoadWords(FileName As String) As String
On Error GoTo handler:
Dim FileNum As Integer
FileNum = FreeFile
Open FileName For Input Access Read As #FileNum
LoadWords = Input(LOF(FileNum), #FileNum)
Close #FileNum
Exit Function
handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical
End Function
Private Sub VBCodeSyntaxHighlight(RTB As RichTextBox)
Static COLOUR_COMMENTS As Long
Static COLOUR_KEYWORDS As Long
COLOUR_COMMENTS = RGB(0, 128, 0)
COLOUR_KEYWORDS = RGB(0, 0, 128)
Dim KeyWords() As String, Functions() As String
Dim Lines() As String, CurLine As String
Dim Line As Integer, LineUBound As Integer
Dim TextPos As Integer, TrimLength As Integer
Dim Pos As Integer
Dim InQuotes As Boolean
Dim ContinuedCommentLine As Boolean
KeyWords = Split(LoadWords(App.Path & "\Keywords.txt"), vbNewLine)
Functions = Split(LoadWords(App.Path & "\Functions.txt"), vbNewLine)
Lines = Split(RTB.Text, vbNewLine)
LineUBound = UBound(Lines)
RTB.SelStart = 0
RTB.SelLength = Len(RTB.Text)
RTB.SelColor = vbBlack
For Line = 0 To LineUBound
CurLine = Trim$(Lines(Line))
TrimLength = Len(Lines(Line)) - Len(CurLine)
For Pos = 1 To Len(CurLine)
If Mid$(CurLine, 1, 1) = """" Then InQuotes = Not InQuotes
RTB.SelStart = TextPos + TrimLength + Pos - 1
If Mid$(CurLine, 1, 4) = "Rem " Or Mid$(CurLine, 1, 1) = "'" Or ContinuedCommentLine Then
If Right$(CurLine, 2) = " _" Then
RTB.SelLength = Len(CurLine) - 2
ContinuedCommentLine = True
Else
RTB.SelLength = Len(CurLine)
ContinuedCommentLine = False
End If
RTB.SelColor = COLOUR_COMMENTS
Exit For
ElseIf Not InQuotes Then
Dim KeyWordsUBound As Integer
Dim KeyWordsPos As Integer
KeyWordsUBound = UBound(KeyWords)
For KeyWordsPos = 0 To KeyWordsUBound
If Mid$(" " & CurLine & " ", Pos, Len(KeyWords(KeyWordsPos)) + 2) = " " & KeyWords(KeyWordsPos) & " " Then
RTB.SelLength = Len(KeyWords(KeyWordsPos))
RTB.SelColor = COLOUR_KEYWORDS
Pos = Pos + Len(KeyWords(KeyWordsPos)) - 1
Exit For
End If
Next KeyWordsPos
KeyWordsUBound = UBound(Functions)
For KeyWordsPos = 0 To KeyWordsUBound
If Mid$(" " & CurLine, Pos, Len(Functions(KeyWordsPos)) + 2) = " " & Functions(KeyWordsPos) & "(" Then
RTB.SelLength = Len(Functions(KeyWordsPos))
RTB.SelColor = COLOUR_KEYWORDS
Pos = Pos + Len(KeyWords(KeyWordsPos)) - 1
Exit For
End If
Next KeyWordsPos
End If
DoEvents
Next Pos
TextPos = TextPos + Len(CurLine) + TrimLength + 2
Next Line
End Sub
Comments