-
Apr 1st, 2023, 03:33 AM
#1
Testing highlighter
Code:
Private Sub Form_Load()
Dim Cnn As cConnection 'InMemory-Connection, and Table-Creation
Set Cnn = New_c.Connection(, DBCreateInMemory)
Cnn.Execute "Create Table T1(ID Integer Primary Key, Txt Text)"
Const S As String = " O'Brien ""!"" " '<- our TestString
Debug.Print "String-Content: "; S; vbLf
Dim Cmd As cCommand, Rs As cRecordset
Set Cmd = Cnn.CreateCommand("Insert Into T1(Txt) Values(?)")
Cmd.SetText 1, S 'take the string as is (no special treatment needed)
Cmd.Execute
Set Rs = Cnn.OpenRecordset("Select * From T1")
Debug.Print "TxtFld-Content: "; Rs!Txt
Dim Sel As cSelectCommand '<- there's a second type of Command-Obj for Selects
Set Sel = Cnn.CreateSelectCommand("Select * From T1 Where Txt=?")
Sel.SetText 1, S 'take the string as is (no special treatment needed)
Set Rs = Sel.Execute
Debug.Print "TxtFld-Content: "; Rs!Txt
'only in directly given SQL-Strings, a Helper-Func would make sense
Set Rs = Cnn.OpenRecordset("Select * From T1 Where Txt=" & SingleQuotes(S))
Debug.Print "TxtFld-Content: "; Rs!Txt; vbLf
End Sub
Private Function SingleQuotes(S As String) As String
SingleQuotes = "'" & Replace(S, "'", "''") & "'"
End Function
-
Apr 1st, 2023, 03:34 AM
#2
Re: Testing highlighter
Code:
Option Explicit
Private Declare Function CryptAcquireContextW Lib "advapi32.dll" (hProv As Long, ByVal pszContainer As Long, ByVal pszProvider As Long, ByVal dwProvType As Long, ByVal dwFlags As Long) As Boolean
Private Declare Function CryptGenRandom Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwlen As Long, pbBuffer As Any) As Boolean
Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
Private Function RandomDecimal() As Variant
' This will return a random decimal number between 0 and 1, inclusive of 0 and exclusive of 1, with 64 bits (8 bytes) of precision.
Dim v1 As Variant
Dim v2 As Variant
Dim hCrypt As Long
Const PROV_RSA_FULL As Long = 1&
Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
'
v1 = CDec(0) ' Create a Decimal number (zero).
Call CryptAcquireContextW(hCrypt, 0&, 0&, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT) ' Initialize advapi32.
Call CryptGenRandom(hCrypt, 8&, ByVal PtrAdd(VarPtr(v1), 8&)) ' Get 8 bytes of random bits, and stuff into low order of Decimal.
Call CryptReleaseContext(hCrypt, 0&) ' Turn off advapi32.
'
v2 = CDec(0) ' Create another Decimal number (zero).
GetMem4 1&, ByVal PtrAdd(VarPtr(v2), 4&) ' Turn on low bit of high (third) byte of mantissa, making: &h100000000.
'
RandomDecimal = v1 / v2 ' Since v2 is 1 higher than v1 can ever be, the results will never reach ONE.
End Function
Public Function PtrAdd(ByVal Ptr As Long, ByVal iOffset As Long) As Long
' For adding (or subtracting) a small number from a pointer.
' Use PtrAddEx for adding (or subtracting) large numbers from a pointer.
PtrAdd = (Ptr Xor &H80000000) + iOffset Xor &H80000000
End Function
Private Sub Form_Load()
' Just a bit of a test.
Dim i As Long
For i = 1 To 20
Debug.Print RandomDecimal
Next
End Sub
-
Apr 1st, 2023, 03:35 AM
#3
Re: Testing highlighter
Code:
Private Sub DatagridView_RowsAdded(sender As Object, e As DataGridViewRowsAddedEventArgs) Handles Report.RowsAdded
With DirectCast(sender, DataGridView)
If find = True Then
.Item(5, e.RowIndex).Style.BackColor = Color.Gold
.Item(5, e.RowIndex).Style.ForeColor = Color.BlueViolet
.Item(5, e.RowIndex).Style.Font = New Font("Rockwell", 10)
End If
If .Item(5, e.RowIndex).Value Is "1234" Then
.Item(5, e.RowIndex).Style.BackColor = Color.Green
End If
If .Item(5, e.RowIndex).Value Is "5678" Then
.Item(5, e.RowIndex).Style.BackColor = Color.Red
End If
If Form1.ComboBox3.Text = "asdf" Then
.Item(1, e.RowIndex).Style.BackColor = Color.LightBlue
End If
If Form1.ComboBox3.Text = "qwerty" Then
.Item(1, e.RowIndex).Style.BackColor = Color.Orchid
End If
If Form1.ComboBox3.Text = "zxcv" Then
.Item(1, e.RowIndex).Style.BackColor = Color.Orange
End If
If Form1.ComboBox3.Text = "ghjk" Then
.Item(1, e.RowIndex).Style.BackColor = Color.Coral
End If
.Item(2, e.RowIndex).Style.BackColor = Color.Silver
.Item(3, e.RowIndex).Style.BackColor = Color.Silver
.Item(4, e.RowIndex).Style.BackColor = Color.Silver
End With
find = False
End Sub
-
Apr 1st, 2023, 03:37 AM
#4
Re: Testing highlighter
Code:
For value As Integer = 0 To Report.Rows.Count - 1
For Each dgvc As DataGridViewCell In Report.Rows(value).Cells
Dim cellcolor = dgvc.Style.BackColor
strB.AppendFormat("<td align=""center"" valign=""middle"" style=""{0}"" bgcolor=""{0}"" >{1}</td>", cellcolor.Name, dgvc.Value.ToString)
Next
strB.AppendLine("</tr>")
Next
-
Apr 1st, 2023, 03:38 AM
#5
Re: Testing highlighter
Code:
Imports System.IO.Compression
Imports System.IO
Public Class FileCompression
Public Shared Sub CompressFile(ByVal sourceFile As String, ByVal destFile As String)
Dim destStream As New FileStream(destFile, FileMode.Create, FileAccess.Write, FileShare.Read)
Dim srcStream As New FileStream(sourceFile, FileMode.Open, FileAccess.Read, FileShare.Read)
Dim gz As New GZipStream(destStream, CompressionMode.Compress)
Dim bytesRead As Integer
Dim buffer As Byte() = New Byte(10000) {}
bytesRead = srcStream.Read(buffer, 0, buffer.Length)
While bytesRead <> 0
gz.Write(buffer, 0, bytesRead)
bytesRead = srcStream.Read(buffer, 0, buffer.Length)
End While
gz.Close()
destStream.Close()
srcStream.Close()
End Sub
Public Shared Sub DecompressFile(ByVal sourceFile As String, ByVal destFile As String)
Dim destStream As New FileStream(destFile, FileMode.Create, FileAccess.Write, FileShare.Read)
Dim srcStream As New FileStream(sourceFile, FileMode.Open, FileAccess.Read, FileShare.Read)
Dim gz As New GZipStream(srcStream, CompressionMode.Decompress)
Dim bytesRead As Integer
Dim buffer As Byte() = New Byte(10000) {}
bytesRead = gz.Read(buffer, 0, buffer.Length)
While bytesRead <> 0
destStream.Write(buffer, 0, bytesRead)
bytesRead = gz.Read(buffer, 0, buffer.Length)
End While
gz.Close()
destStream.Close()
srcStream.Close()
End Sub
End Class
-
Apr 1st, 2023, 03:40 AM
#6
Re: Testing highlighter
Code:
Private Declare Sub GetMem2 Lib "msvbvm60" (ByVal Addr As Long, retval As Integer)
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)
Private Declare Sub PutMem2 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Integer)
Private Declare Sub PutMem1 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Byte)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private maxlonglong, limitlonglong
Sub main()
maxlonglong = CDec("18446744073709551616")
limitlonglong = CDec("9223372036854775808")
Dim a, b
a = cInt64("12345678912345678")
Debug.Print a, VarTypeName(a)
Debug.Print a \ 2, VarTypeName(a \ 2)
b = cInt64(123)
a = IntExp(cInt64(2), cInt64(62), OneLongLong) ' 2^62 (2^63 return right bits for unsigned, but as negative signed)
Debug.Print a, " = 2^62"
Debug.Print Hex64(a)
Debug.Print a \ cInt64(1234), VarTypeName(a \ cInt64(1234))
'a = OneLongLong
a = IntExp(cInt64(2), cInt64(63), OneLongLong)
Debug.Print Hex64(a)
Debug.Print cInt64("&H7FFFFFFFFFFFFFFF")
Debug.Print cInt64("&H8000000000000000")
Debug.Print cInt64("&H00000000FFFFFFFF") ' always feed the zero to get unsigned long as long long
End Sub
Public Function myVarType(z, j As Integer) As Boolean
Dim i As Integer
GetMem2 VarPtr(z), i
myVarType = i = j
End Function
Public Function IntExp(n, x, ByVal R)
On Error GoTo 100
While x > 0: If x Mod 2 = 1 Then x = x - 1: R = R * n
x = x \ 2: If x > 0 Then n = n * n
Wend
IntExp = R
Exit Function
100: Err.Clear
R = 0.5
End Function
Public Function VarTypeName(v) As String
Dim n As Integer
GetMem2 VarPtr(v), n
Select Case n And &H7FF
Case 0
VarTypeName = "Empty"
Case 1
VarTypeName = "Null"
Case 2
VarTypeName = "Integer"
Case 3
VarTypeName = "Long"
Case 4
VarTypeName = "Single"
Case 5
VarTypeName = "Double"
Case 6
VarTypeName = "Currency"
Case 7
VarTypeName = "Date"
Case 8
VarTypeName = "String"
Case 10
VarTypeName = "Error"
Case 9, 13
VarTypeName = TypeName(v)
Case 11
VarTypeName = "Boolean"
Case 12, 1, 36
VarTypeName = "Variant"
Case 14
VarTypeName = "Decimal"
Case 17
VarTypeName = "Byte"
Case 20
VarTypeName = "Long Long"
Case 8204
VarTypeName = "Variant()"
Case Is > 8000
On Error GoTo 1000
If UBound(v) > LBound(v) Then
VarTypeName = VarTypeName(v(LBound(v))) + "()"
If VarTypeName = "Nothing()" Then VarTypeName = "Object()"
Else
1000 If Err.Number <> 0 Then Err.Clear
VarTypeName = "Array"
End If
Case Else
VarTypeName = "type" & VarType(v)
End Select
End Function
Public Function HighLong(a) As Long
HighLong = LowLong(cInt64(a) \ OneBigLongLong())
End Function
Public Function LowLong(ByVal p) As Long
If Not myVarType(p, 20) Then p = cInt64(p)
CopyMemory ByVal VarPtr(LowLong), ByVal VarPtr(p) + 8, 4
End Function
Function Hex64$(a, Optional showlong)
Dim p, p1, sg As Integer
a = cInt64(a)
sg = Sgn(a)
p = -OneLongLong() And a
p1 = p \ OneBigLongLong()
p1 = LowLong(p1)
p = LowLong(p)
If Not IsMissing(showlong) Then If showlong Then sg = Sgn(p)
If p1 = 0 And sg = -1 Then
Hex64$ = "FFFFFFFF" + Right$("0000000" + Hex$(p), 8)
Else
Hex64$ = Right$("0000000" + Hex$(p1), 8) + Right$("0000000" + Hex$(p), 8)
End If
End Function
Public Function OneLongLong() As Variant
Static p
If p = Empty Then
PutMem2 VarPtr(p), 20
PutMem1 VarPtr(p) + 8, 1
End If
OneLongLong = p
End Function
Public Function OneBigLongLong() As Variant
Static p
If p = Empty Then
PutMem2 VarPtr(p), 20
PutMem1 VarPtr(p) + 12, 1
End If
OneBigLongLong = p
End Function
Public Function MaskLowLongLong() As Variant
PutMem2 VarPtr(OneBigLongLong), 20
PutMem4 VarPtr(OneBigLongLong) + 12, -1&
End Function
Public Function cInt64(p)
Dim a
Dim i As Integer
GetMem2 VarPtr(p), i
Select Case i
Case vbDecimal
a = Fix(p)
If a < -limitlonglong - 1 Then
While a <= -limitlonglong - 1: a = a + maxlonglong: Wend
End If
While a > limitlonglong: a = a - maxlonglong: Wend
cInt64 = -OneLongLong() And a
Case 20
cInt64 = p
Case vbLong, vbInteger
cInt64 = -OneLongLong() And p
Case Else
a = Fix(CDec(p))
If a <= -limitlonglong - 1 Then
While a <= -limitlonglong - 1: a = a + maxlonglong: Wend
End If
While a > limitlonglong: a = a - maxlonglong: Wend
cInt64 = -OneLongLong() And a
If i = vbString Then
If Left$(p, 1) = "&" And a < 0 Then
If Len(p) = 10 Then
If InStr("89ABCDEF", UCase(Mid$(p, 3, 1))) = 1 Then
cInt64 = OneBigLongLong() + cInt64
End If
Else
If InStr("89ABCDEF", UCase(Mid$(p, 3, 1))) = 0 Then
cInt64 = OneBigLongLong() + cInt64
End If
End If
End If
End If
End Select
End Function
-
Apr 1st, 2023, 08:31 PM
#7
Re: Testing highlighter
Code:
Imports System.Text
Imports System.Text.RegularExpressions
Imports System.Collections.Generic
'Everything is here was almost entirely by
'ChatGPT GPT-4
'**********************************************
Public Enum TokenType
None
Keyword
Type
SingleQuote
DoubleQuote
Number
End Enum
Public Class TokenInfo
Public Property Value As String
Public Property Type As TokenType
Public Sub New(ByVal value As String, ByVal type As TokenType)
Me.Value = value
Me.Type = type
End Sub
End Class
Public Class SyntaxHighlighter
Public Shared Function ApplyBBCodeTags(ByVal text As String) As String
Return WrapTokenInfosWithColorTags(GetTokenInfos(Tokenize(text)))
End Function
Public Shared Function GetTokenInfos(tokens As String()) As TokenInfo()
Dim keywords As New List(Of String)({"As", "For", "Next", "End", "Class",
"Structure", "Dim", "Private", "Public", "Friend",
"Sub", "Function", "Property", "If", "Else", "Implements",
"Inherits", "DirectCast", "CType", "Handles", "Ubound", "Lbound",
"Optional", "ByVal", "ByRef", "Each",
"Continue", "CDec", "CInt", "CLng",
"Cstr", "CBool", "Redim", "Preserve", "True", "False",
"Static", "Shared", "Overloads",
"Of", "From", "Try", "Catch", "Finally", "Do", "While", "When"})
Dim types As New List(Of String)({"Single", "Double", "String",
"Boolean", "Integer", "Long", "Short",
"Byte"})
Dim tokenInfos As New List(Of TokenInfo)
For Each token As String In tokens
Dim tokenType As TokenType = TokenType.None
Dim tokenUpper As String = token.ToUpperInvariant()
Dim isNumber As Double
If keywords.Any(Function(k) k.ToUpperInvariant() = tokenUpper) Then
tokenType = TokenType.Keyword
ElseIf types.Any(Function(t) t.ToUpperInvariant() = tokenUpper) Then
tokenType = TokenType.Type
ElseIf token.StartsWith("'"c) Then
tokenType = TokenType.SingleQuote
ElseIf token.StartsWith(""""c) Then
tokenType = TokenType.DoubleQuote
ElseIf Double.TryParse(token, isNumber) Then
tokenType = TokenType.Number
End If
tokenInfos.Add(New TokenInfo(token, tokenType))
Next
Return tokenInfos.ToArray()
End Function
Public Shared Function WrapTokenInfosWithColorTags(tokenInfos As TokenInfo()) As String
Dim tokenColors As New Dictionary(Of TokenType, String) From {
{TokenType.Keyword, "#A52A2A"},
{TokenType.Type, "#4B0082"},
{TokenType.SingleQuote, "#006400"},
{TokenType.DoubleQuote, "#8B4513"},
{TokenType.Number, "#FF0000"}
}
Dim sb As New StringBuilder()
sb.Append("[CODE]")
sb.Append("[COLOR=""#000080""]")
For Each tokenInfo As TokenInfo In tokenInfos
Dim color As String = ""
If tokenColors.ContainsKey(tokenInfo.Type) Then
color = tokenColors(tokenInfo.Type)
End If
Dim token As String = tokenInfo.Value
token = Regex.Replace(token, "code", "$0", RegexOptions.IgnoreCase)
token = Regex.Replace(token, "color", "$0", RegexOptions.IgnoreCase)
If Not String.IsNullOrEmpty(color) Then
sb.AppendFormat("[COLOR=""{0}""]{1}[/COLOR]", color, token)
Else
sb.Append(token)
End If
Next
sb.Append("[/COLOR]")
sb.Append("[/CODE]")
Return sb.ToString()
End Function
Private Shared Function WrapTokensWithColorTags(tokens As String()) As String
Dim tokenColors As New Dictionary(Of String, String) From {
{"Keywords", "#A52A2A"},
{"Types", "#4B0082"},
{"SingleQuote", "#006400"},
{"DoubleQuote", "#8B4513"},
{"Numbers", "#FF0000"}
}
Dim keywords As New List(Of String)({"As", "For", "Next", "End", "Class",
"Structure", "Dim", "Private", "Public", "Friend",
"Sub", "Function", "Property", "If", "Else", "Implements",
"Inherits", "DirectCast", "CType", "Handles", "Ubound", "Lbound",
"Optional", "ByVal", "ByRef", "Each",
"Continue", "CDec", "CInt", "CLng",
"Cstr", "CBool", "Redim", "Preserve", "True", "False",
"Static", "Shared", "Overloads",
"Of", "From", "Try", "Catch", "Finally", "Do", "While", "When"})
Dim types As New List(Of String)({"Single", "Double", "String",
"Boolean", "Integer", "Long", "Short",
"Byte"})
Dim sb As New StringBuilder()
sb.Append("[CODE]")
sb.Append("[COLOR=""#000080""]")
For Each token As String In tokens
Dim color As String = ""
Dim tokenUpper As String = token.ToUpperInvariant()
Dim isNumber As Double
token = Regex.Replace(token, "code", "$0", RegexOptions.IgnoreCase)
token = Regex.Replace(token, "color", "$0", RegexOptions.IgnoreCase)
If keywords.Any(Function(k) k.ToUpperInvariant() = tokenUpper) Then
color = tokenColors("Keywords")
ElseIf types.Any(Function(t) t.ToUpperInvariant() = tokenUpper) Then
color = tokenColors("Types")
ElseIf token.StartsWith("'"c) Then
color = tokenColors("SingleQuote")
ElseIf token.StartsWith(""""c) Then
color = tokenColors("DoubleQuote")
ElseIf Double.TryParse(token, isNumber) Then
color = tokenColors("Numbers")
ElseIf token.StartsWith(vbLf) OrElse token.StartsWith(vbCr) OrElse token.StartsWith(" "c) Then
sb.Append(token)
Continue For
End If
If Not String.IsNullOrEmpty(color) Then
sb.AppendFormat("[COLOR=""{0}""]{1}[/COLOR]", color, token)
Else
sb.Append(token)
End If
Next
sb.Append("[/COLOR]")
sb.Append("[/CODE]")
Return sb.ToString()
End Function
Private Shared Function Tokenize(input As String) As String()
Dim tokens As New List(Of String)()
Dim token As New System.Text.StringBuilder()
Dim index As Integer = 0
While index < input.Length
Dim ch As Char = input(index)
If Char.IsWhiteSpace(ch) Then
AddTokenAndClear(tokens, token)
index = HandleWhiteSpace(input, index, tokens)
ElseIf ch = "'"c Then
AddTokenAndClear(tokens, token)
index = HandleSingleQuote(input, index, tokens)
ElseIf ch = """"c Then
AddTokenAndClear(tokens, token)
index = HandleDoubleQuote(input, index, tokens)
ElseIf IsAlphaNumeric(ch) OrElse ch = "_"c OrElse (ch = "."c AndAlso token.Length > 0 AndAlso Char.IsDigit(token(token.Length - 1))) Then
token.Append(ch)
index += 1
ElseIf IsSpecialCharacter(ch) Then
AddTokenAndClear(tokens, token)
tokens.Add(ch.ToString())
index += 1
ElseIf ch = vbCr OrElse ch = vbLf Then
AddTokenAndClear(tokens, token)
index = HandleNewLine(input, index, tokens)
Else
index += 1
End If
End While
AddTokenAndClear(tokens, token)
Return tokens.ToArray()
End Function
Private Shared Sub AddTokenAndClear(tokens As List(Of String), token As System.Text.StringBuilder)
If token.Length > 0 Then
tokens.Add(token.ToString())
token.Clear()
End If
End Sub
Private Shared Function HandleWhiteSpace(input As String, index As Integer, tokens As List(Of String)) As Integer
Dim ws As New System.Text.StringBuilder()
While index < input.Length AndAlso Char.IsWhiteSpace(input(index))
ws.Append(input(index))
index += 1
End While
tokens.Add(ws.ToString())
Return index
End Function
Private Shared Function HandleSingleQuote(input As String, index As Integer, tokens As List(Of String)) As Integer
Dim comment As New System.Text.StringBuilder()
comment.Append(input(index))
index += 1
While index < input.Length AndAlso Not (input(index) = vbCr OrElse input(index) = vbLf)
comment.Append(input(index))
index += 1
End While
tokens.Add(comment.ToString())
Return index
End Function
Private Shared Function HandleDoubleQuote(input As String, index As Integer, tokens As List(Of String)) As Integer
Dim quoted As New System.Text.StringBuilder()
quoted.Append(input(index))
index += 1
While index < input.Length
Dim ch As Char = input(index)
If ch = """"c Then
quoted.Append(ch)
index += 1
If index < input.Length AndAlso input(index) = """"c Then
quoted.Append(input(index))
index += 1
Else
Exit While
End If
Else
quoted.Append(ch)
index += 1
End If
End While
tokens.Add(quoted.ToString())
Return index
End Function
Private Shared Function HandleNewLine(input As String, index As Integer, tokens As List(Of String)) As Integer
If index + 1 < input.Length AndAlso input(index) = vbCr AndAlso input(index + 1) = vbLf Then
tokens.Add(vbCrLf)
index += 2
ElseIf input(index) = vbCr OrElse input(index) = vbLf Then
tokens.Add(input(index).ToString())
index += 1
End If
Return index
End Function
Private Shared Function IsAlphaNumeric(ch As Char) As Boolean
Return Char.IsLetterOrDigit(ch)
End Function
Private Shared Function IsSpecialCharacter(ch As Char) As Boolean
Return Not (IsAlphaNumeric(ch) OrElse Char.IsWhiteSpace(ch) OrElse ch = "_"c OrElse ch = "'"c OrElse ch = """"c OrElse ch = vbCr OrElse ch = vbLf)
End Function
End Class
-
Apr 2nd, 2023, 01:56 AM
#8
Re: Testing highlighter
Code:
Imports System.Text
Imports System.Text.RegularExpressions
Imports System.Collections.Generic
'Everything is here was almost entirely by
'ChatGPT GPT-4
'**********************************************
Public Enum TokenType
None
Keyword
Type
SingleQuote
DoubleQuote
Number
End Enum
Public Class TokenInfo
Public Property Value As String
Public Property Type As TokenType
Public Sub New(ByVal value As String, ByVal type As TokenType)
Me.Value = value
Me.Type = type
End Sub
End Class
Public Class SyntaxHighlighter
Private Shared tokenColors As New Dictionary(Of TokenType, String) From {
{TokenType.Keyword, "#A52A2A"},
{TokenType.Type, "#4B0082"},
{TokenType.SingleQuote, "#006400"},
{TokenType.DoubleQuote, "#8B4513"},
{TokenType.Number, "#FF0000"}
}
Public Shared Sub SetTokenColor(tokenType As TokenType, color As Color)
Dim colorString As String = $"#{color.R:X2}{color.G:X2}{color.B:X2}"
If tokenColors.ContainsKey(tokenType) Then
tokenColors(tokenType) = colorString
Else
tokenColors.Add(tokenType, colorString)
End If
End Sub
' Add a new static method to get the color of any token type as a color object
Public Shared Function GetTokenColor(tokenType As TokenType) As Color
If tokenColors.ContainsKey(tokenType) Then
Dim colorString As String = tokenColors(tokenType)
Dim r As Byte = Convert.ToByte(colorString.Substring(1, 2), 16)
Dim g As Byte = Convert.ToByte(colorString.Substring(3, 2), 16)
Dim b As Byte = Convert.ToByte(colorString.Substring(5, 2), 16)
Return Color.FromRgb(r, g, b)
Else
Return Color.FromArgb(0, 0, 0, 0) ' Transparent color
End If
End Function
Public Shared Function ApplyBBCodeTags(ByVal text As String) As String
Return TransformToBBCode(GetTokenInfos(Tokenize(text)))
End Function
Public Shared Function GetTokenInfos(tokens As String()) As TokenInfo()
Dim keywords As New List(Of String)({"As", "For", "Next", "End", "Class",
"Structure", "Dim", "Private", "Public", "Friend",
"Sub", "Function", "Property", "If", "Else", "Implements",
"Inherits", "DirectCast", "CType", "Handles", "Ubound", "Lbound",
"Optional", "ByVal", "ByRef", "Each",
"Continue", "CDec", "CInt", "CLng",
"Cstr", "CBool", "Redim", "Preserve", "True", "False",
"Static", "Shared", "Overloads",
"Of", "From", "Try", "Catch", "Finally", "Do", "While", "When"})
Dim types As New List(Of String)({"Single", "Double", "String",
"Boolean", "Integer", "Long", "Short",
"Byte"})
Dim tokenInfos As New List(Of TokenInfo)
For Each token As String In tokens
Dim tokenType As TokenType = TokenType.None
Dim tokenUpper As String = token.ToUpperInvariant()
Dim isNumber As Double
If keywords.Any(Function(k) k.ToUpperInvariant() = tokenUpper) Then
tokenType = TokenType.Keyword
ElseIf types.Any(Function(t) t.ToUpperInvariant() = tokenUpper) Then
tokenType = TokenType.Type
ElseIf token.StartsWith("'"c) Then
tokenType = TokenType.SingleQuote
ElseIf token.StartsWith(""""c) Then
tokenType = TokenType.DoubleQuote
ElseIf Double.TryParse(token, isNumber) Then
tokenType = TokenType.Number
End If
tokenInfos.Add(New TokenInfo(token, tokenType))
Next
Return tokenInfos.ToArray()
End Function
Private Shared Function TransformToBBCode(tokenInfos As TokenInfo()) As String
Dim sb As New StringBuilder()
sb.Append("[CODE]")
sb.Append("[COLOR=""#000080""]")
For Each tokenInfo As TokenInfo In tokenInfos
Dim color As String = ""
If tokenColors.ContainsKey(tokenInfo.Type) Then
color = tokenColors(tokenInfo.Type)
End If
Dim token As String = tokenInfo.Value
token = Regex.Replace(token, "code", "$0", RegexOptions.IgnoreCase)
token = Regex.Replace(token, "color", "$0", RegexOptions.IgnoreCase)
If Not String.IsNullOrEmpty(color) Then
sb.AppendFormat("[COLOR=""{0}""]{1}[/COLOR]", color, token)
Else
sb.Append(token)
End If
Next
sb.Append("[/COLOR]")
sb.Append("[/CODE]")
Return sb.ToString()
End Function
'Private Shared Function TransformToBBCode(tokenInfos As TokenInfo()) As String
' Dim tokenColors As New Dictionary(Of TokenType, String) From {
' {TokenType.Keyword, "#A52A2A"},
' {TokenType.Type, "#4B0082"},
' {TokenType.SingleQuote, "#006400"},
' {TokenType.DoubleQuote, "#8B4513"},
' {TokenType.Number, "#FF0000"}
'}
' Dim sb As New StringBuilder()
' sb.Append("[CODE]")
' sb.Append("[COLOR=""#000080""]")
' For Each tokenInfo As TokenInfo In tokenInfos
' Dim color As String = ""
' If tokenColors.ContainsKey(tokenInfo.Type) Then
' color = tokenColors(tokenInfo.Type)
' End If
' Dim token As String = tokenInfo.Value
' token = Regex.Replace(token, "code", "$0", RegexOptions.IgnoreCase)
' token = Regex.Replace(token, "color", "$0", RegexOptions.IgnoreCase)
' If Not String.IsNullOrEmpty(color) Then
' sb.AppendFormat("[COLOR=""{0}""]{1}[/COLOR]", color, token)
' Else
' sb.Append(token)
' End If
' Next
' sb.Append("[/COLOR]")
' sb.Append("[/CODE]")
' Return sb.ToString()
'End Function
Private Shared Function Tokenize(input As String) As String()
Dim tokens As New List(Of String)()
Dim token As New System.Text.StringBuilder()
Dim index As Integer = 0
While index < input.Length
Dim ch As Char = input(index)
If Char.IsWhiteSpace(ch) Then
AddTokenAndClear(tokens, token)
index = HandleWhiteSpace(input, index, tokens)
ElseIf ch = "'"c Then
AddTokenAndClear(tokens, token)
index = HandleSingleQuote(input, index, tokens)
ElseIf ch = """"c Then
AddTokenAndClear(tokens, token)
index = HandleDoubleQuote(input, index, tokens)
ElseIf IsAlphaNumeric(ch) OrElse ch = "_"c OrElse (ch = "."c AndAlso token.Length > 0 AndAlso Char.IsDigit(token(token.Length - 1))) Then
token.Append(ch)
index += 1
ElseIf IsSpecialCharacter(ch) Then
AddTokenAndClear(tokens, token)
tokens.Add(ch.ToString())
index += 1
ElseIf ch = vbCr OrElse ch = vbLf Then
AddTokenAndClear(tokens, token)
index = HandleNewLine(input, index, tokens)
Else
index += 1
End If
End While
AddTokenAndClear(tokens, token)
Return tokens.ToArray()
End Function
Private Shared Sub AddTokenAndClear(tokens As List(Of String), token As System.Text.StringBuilder)
If token.Length > 0 Then
tokens.Add(token.ToString())
token.Clear()
End If
End Sub
Private Shared Function HandleWhiteSpace(input As String, index As Integer, tokens As List(Of String)) As Integer
Dim ws As New System.Text.StringBuilder()
While index < input.Length AndAlso Char.IsWhiteSpace(input(index))
ws.Append(input(index))
index += 1
End While
tokens.Add(ws.ToString())
Return index
End Function
Private Shared Function HandleSingleQuote(input As String, index As Integer, tokens As List(Of String)) As Integer
Dim comment As New System.Text.StringBuilder()
comment.Append(input(index))
index += 1
While index < input.Length AndAlso Not (input(index) = vbCr OrElse input(index) = vbLf)
comment.Append(input(index))
index += 1
End While
tokens.Add(comment.ToString())
Return index
End Function
Private Shared Function HandleDoubleQuote(input As String, index As Integer, tokens As List(Of String)) As Integer
Dim quoted As New System.Text.StringBuilder()
quoted.Append(input(index))
index += 1
While index < input.Length
Dim ch As Char = input(index)
If ch = """"c Then
quoted.Append(ch)
index += 1
If index < input.Length AndAlso input(index) = """"c Then
quoted.Append(input(index))
index += 1
Else
Exit While
End If
Else
quoted.Append(ch)
index += 1
End If
End While
tokens.Add(quoted.ToString())
Return index
End Function
Private Shared Function HandleNewLine(input As String, index As Integer, tokens As List(Of String)) As Integer
If index + 1 < input.Length AndAlso input(index) = vbCr AndAlso input(index + 1) = vbLf Then
tokens.Add(vbCrLf)
index += 2
ElseIf input(index) = vbCr OrElse input(index) = vbLf Then
tokens.Add(input(index).ToString())
index += 1
End If
Return index
End Function
Private Shared Function IsAlphaNumeric(ch As Char) As Boolean
Return Char.IsLetterOrDigit(ch)
End Function
Private Shared Function IsSpecialCharacter(ch As Char) As Boolean
Return Not (IsAlphaNumeric(ch) OrElse Char.IsWhiteSpace(ch) OrElse ch = "_"c OrElse ch = "'"c OrElse ch = """"c OrElse ch = vbCr OrElse ch = vbLf)
End Function
End Class
-
Apr 2nd, 2023, 08:45 PM
#9
Re: Testing highlighter
Code:
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Sub SetArrayLBound(vArray As Variant, ByVal lLBound As Long)
Dim lPtr As Long
If IsArray(vArray) Then
Call CopyMemory(lPtr, ByVal VarPtr(vArray) + 8, 4)
Call CopyMemory(ByVal lPtr + 20, lLBound, 4)
End If
End Sub
Private Sub Form_Load()
Dim vItems As Variant
vItems = Array("aaa", "bbb", "test")
Debug.Print LBound(vItems), vItems(0)
'--> 0 aaa
SetArrayLBound vItems, 1
Debug.Print LBound(vItems), vItems(1)
'--> 1 aaa
End Sub
-
Apr 4th, 2023, 05:26 AM
#10
Re: Testing highlighter
Code:
Option Explicit
Private Enum UcsColorsEnum
ucsClrWhitespace = -1
ucsClrComment = &H8000&
ucsClrIdent = &H0
ucsClrNumber = &HFF0000
ucsClrDate = &HFF0000
ucsClrString = &H808080
ucsClrSymbol = &H808080
ucsClrKeyword = &H80
End Enum
Private Sub Command1_Click()
Dim sSourceCode As String
Dim uResult As UcsTokenizeResult
Dim lIdx As Long
Dim cOutput As Collection
Dim lStartPos As Long
Dim lEndPos As Long
Dim lColor As Long
Dim lPrevColor As Long
Dim sText As String
On Error GoTo EH
sSourceCode = Text1.Text
If TokenizeSourceCode(sSourceCode, uResult) Then
Set cOutput = New Collection
cOutput.Add "[code]"
lPrevColor = -1
lStartPos = 0
For lIdx = 0 To UBound(uResult.Tokens)
With uResult.Tokens(lIdx)
Select Case .Type
Case ucsTypWhitespace
' lColor = ucsClrWhitespace
Case ucsTypComment
lColor = ucsClrComment
Case ucsTypIdent
lColor = ucsClrIdent
Case ucsTypNumber
lColor = ucsClrNumber
Case ucsTypDate
lColor = ucsClrDate
Case ucsTypString
lColor = ucsClrString
Case ucsTypSymbol
If .Tok = ucsTokNewLine Then
' lColor = ucsClrWhitespace
Else
lColor = ucsClrSymbol
End If
Case ucsTypKeyword
lColor = ucsClrKeyword
End Select
If lColor <> lPrevColor Then
lEndPos = .Position
If lEndPos > lStartPos Then
sText = Replace(Mid$(sSourceCode, lStartPos + 1, lEndPos - lStartPos), "[", "[[b][/b]")
If lPrevColor <> -1 Then
cOutput.Add "[color=" & IIf(lPrevColor = 0, 0, "#" & Right$("000000" & Hex$(lPrevColor), 6)) & "]" & sText & "[/color]"
Else
cOutput.Add sText
End If
End If
lStartPos = lEndPos
lPrevColor = lColor
End If
End With
Next
lEndPos = Len(sSourceCode)
If lEndPos > lStartPos Then
sText = Replace(Mid$(sSourceCode, lStartPos + 1, lEndPos - lStartPos), "[", "[[b][/b]")
If lPrevColor <> -1 Then
cOutput.Add "[color=" & IIf(lPrevColor = 0, 0, "#" & Right$("000000" & Hex$(lPrevColor), 6)) & "]" & sText & "[/color]"
Else
cOutput.Add sText
End If
End If
cOutput.Add "[/code]"
With Clipboard
.Clear
.SetText ConcatCollection(cOutput)
End With
MsgBox "Copied to clipboard!", vbExclamation
End If
Exit Sub
EH:
MsgBox Err.Description, vbCritical
End Sub
Public Function ConcatCollection(oCol As Collection, Optional Separator As String) As String
Dim lSize As Long
Dim vElem As Variant
For Each vElem In oCol
lSize = lSize + Len(vElem) + Len(Separator)
Next
If lSize > 0 Then
ConcatCollection = String$(lSize - Len(Separator), 0)
lSize = 1
For Each vElem In oCol
If lSize <= Len(ConcatCollection) Then
Mid$(ConcatCollection, lSize, Len(vElem) + Len(Separator)) = vElem & Separator
End If
lSize = lSize + Len(vElem) + Len(Separator)
Next
End If
End Function
Private Sub Form_Resize()
If WindowState <> vbMinimized Then
Text1.Width = ScaleWidth - 2 * Text1.Left
Text1.Height = ScaleHeight - 2 * Text1.Top - Command1.Height
Command1.Move Text1.Left, Text1.Top + Text1.Height + 60
End If
End Sub
-
Apr 4th, 2023, 07:00 AM
#11
Re: Testing highlighter
Code:
Option Explicit
Private Enum UcsColorsEnum
ucsClrWhitespace = -1
ucsClrComment = &H8000&
ucsClrIdent = &H0
ucsClrNumber = &HFF0000
ucsClrDate = &HFF0000
ucsClrString = &H808080
ucsClrSymbol = &H808080
ucsClrKeyword = &H80
End Enum
Private Sub Command1_Click()
Dim sSourceCode As String
Dim uResult As UcsTokenizeResult
Dim lIdx As Long
Dim cOutput As Collection
Dim lStartPos As Long
Dim lEndPos As Long
Dim lColor As Long
Dim lPrevColor As Long
Dim sText As String
On Error GoTo EH
sSourceCode = Text1.Text
If TokenizeSourceCode(sSourceCode, uResult) Then
Set cOutput = New Collection
cOutput.Add "[code]"
lPrevColor = -1
lStartPos = 0
For lIdx = 0 To UBound(uResult.Tokens)
With uResult.Tokens(lIdx)
Select Case .Type
Case ucsTypWhitespace
' lColor = ucsClrWhitespace
Case ucsTypComment
lColor = ucsClrComment
Case ucsTypIdent
lColor = ucsClrIdent
Case ucsTypNumber
lColor = ucsClrNumber
Case ucsTypDate
lColor = ucsClrDate
Case ucsTypString
lColor = ucsClrString
Case ucsTypSymbol
If .Tok = ucsTokNewLine Then
' lColor = ucsClrWhitespace
Else
lColor = ucsClrSymbol
End If
Case ucsTypKeyword
lColor = ucsClrKeyword
End Select
If lColor <> lPrevColor Then
lEndPos = .Position
If lEndPos > lStartPos Then
sText = Replace(Mid$(sSourceCode, lStartPos + 1, lEndPos - lStartPos), "[", "[")
If lPrevColor <> -1 Then
cOutput.Add "[color=" & IIf(lPrevColor = 0, 0, "#" & Right$("000000" & Hex$(lPrevColor), 6)) & "]" & sText & "[/color]"
Else
cOutput.Add sText
End If
End If
lStartPos = lEndPos
lPrevColor = lColor
End If
End With
Next
lEndPos = Len(sSourceCode)
If lEndPos > lStartPos Then
sText = Replace(Mid$(sSourceCode, lStartPos + 1, lEndPos - lStartPos), "[", "[")
If lPrevColor <> -1 Then
cOutput.Add "[color=" & IIf(lPrevColor = 0, 0, "#" & Right$("000000" & Hex$(lPrevColor), 6)) & "]" & sText & "[/color]"
Else
cOutput.Add sText
End If
End If
cOutput.Add "[/code]"
With Clipboard
.Clear
.SetText ConcatCollection(cOutput)
End With
MsgBox "Copied to clipboard!", vbExclamation
End If
Exit Sub
EH:
MsgBox Err.Description, vbCritical
End Sub
Public Function ConcatCollection(oCol As Collection, Optional Separator As String) As String
Dim lSize As Long
Dim vElem As Variant
For Each vElem In oCol
lSize = lSize + Len(vElem) + Len(Separator)
Next
If lSize > 0 Then
ConcatCollection = String$(lSize - Len(Separator), 0)
lSize = 1
For Each vElem In oCol
If lSize <= Len(ConcatCollection) Then
Mid$(ConcatCollection, lSize, Len(vElem) + Len(Separator)) = vElem & Separator
End If
lSize = lSize + Len(vElem) + Len(Separator)
Next
End If
End Function
Private Sub Form_Resize()
If WindowState <> vbMinimized Then
Text1.Width = ScaleWidth - 2 * Text1.Left
Text1.Height = ScaleHeight - 2 * Text1.Top - Command1.Height
Command1.Move Text1.Left, Text1.Top + Text1.Height + 60
End If
End Sub
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|