Results 1 to 11 of 11

Thread: Testing highlighter

  1. #1

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  2. #2

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  3. #3

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  4. #4

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  5. #5

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  6. #6

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  7. #7

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    
    
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  8. #8

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    
    
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  9. #9

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

  10. #10
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    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
    

  11. #11

    Thread Starter
    Angel of Code Niya's Avatar
    Join Date
    Nov 2011
    Posts
    8,598

    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
    Treeview with NodeAdded/NodesRemoved events | BlinkLabel control | Calculate Permutations | Object Enums | ComboBox with centered items | .Net Internals article(not mine) | Wizard Control | Understanding Multi-Threading | Simple file compression | Demon Arena

    Copy/move files using Windows Shell | I'm not wanted

    C++ programmers will dismiss you as a cretinous simpleton for your inability to keep track of pointers chained 6 levels deep and Java programmers will pillory you for buying into the evils of Microsoft. Meanwhile C# programmers will get paid just a little bit more than you for writing exactly the same code and VB6 programmers will continue to whitter on about "footprints". - FunkyDexter

    There's just no reason to use garbage like InputBox. - jmcilhinney

    The threads I start are Niya and Olaf free zones. No arguing about the benefits of VB6 over .NET here please. Happiness must reign. - yereverluvinuncleber

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width