csyntax.cls

VB写的一个IDE开发环境,支持脚本运行,内置了一个简单的编译器,可以直接生成EXE.. 推荐下载!

Dim l       As Long
Dim sTmp        As String
Dim iProgress   As Integer      '*当前处理进度
Dim iTmp        As Integer
'Dim rtfText As String
Dim rtfFontSize As Integer
    
    sTmp = ctrl.Text
    l = Len(sTmp)
    If l = 0 Then Exit Sub      '内容长度为0，退出
    
    rtfFontSize = ctrl.Font.Size    '字体大小
    If rtfFontSize Mod 3 = 2 Then
        rtfFontSize = rtfFontSize * 2 + 1
    Else
        rtfFontSize = rtfFontSize * 2
    End If
    
    '生成 RTF 格式字符
    'rtfText = HEAD_FIRST & m_sColorRtf & HEAD_LAST & CStr(rtfFontSize) & " "
    m_oString.Append HEAD_FIRST & m_sColorRtf & HEAD_LAST & CStr(rtfFontSize) & " "
    
    m_iQuotState = 0
    m_iCommState = 0
    
    iProgress = 0
    
    '*对于大文本进行分块处理，每1K为一个单位
    Dim aTmp()      As String
    Dim j           As Long
    Dim lstPos      As Long
    lstPos = 1
    ReDim aTmp(1 To l / 4000 + 1)
    For i = 1 To UBound(aTmp)
        j = InStr(lstPos + 4000, sTmp, vbCrLf, vbTextCompare)
        If j = 0 Then
            j = l
            aTmp(i) = Mid(sTmp, lstPos, j - lstPos + 1)
            lstPos = -1
        Else
            aTmp(i) = Mid(sTmp, lstPos, j - lstPos + 1)
            lstPos = j + 1
        End If
        
        '*处理功能字符和分隔字符
        aTmp(i) = Replace(aTmp(i), "\", "\\")
        aTmp(i) = Replace(aTmp(i), "{", "\{")
        aTmp(i) = Replace(aTmp(i), "}", "\}")
        aTmp(i) = Replace(aTmp(i), "(", " ( ")
        aTmp(i) = Replace(aTmp(i), ")", " ) ")
        aTmp(i) = Replace(aTmp(i), ";", " ; ")
        aTmp(i) = Replace(aTmp(i), "#", " # ")
        aTmp(i) = Replace(aTmp(i), Chr(9), " " & Chr(9) & " ")
        aTmp(i) = Replace(aTmp(i), vbTab, " " & vbTab & " ")
    
        sLine = Split(aTmp(i), vbCrLf)
        
        For j = 0 To UBound(sLine)
        
            Call HighLightLine(sLine(j))    '*处理一行
            
            '*恢复分隔字符
            aTmp(i) = Replace(sLine(j), " ( ", "(")
            aTmp(i) = Replace(aTmp(i), " ) ", ")")
            aTmp(i) = Replace(aTmp(i), " ; ", ";")
            aTmp(i) = Replace(aTmp(i), " # ", "#")
            aTmp(i) = Replace(aTmp(i), " " & Chr(9) & " ", Chr(9))
            aTmp(i) = Replace(aTmp(i), " " & vbTab & " ", vbTab)
            
            'rtfText = rtfText & aTmp(i) & "\par "
            aTmp(i) = aTmp(i) & "\par "
            m_oString.Append aTmp(i)
    
        Next j
        
        If lstPos = -1 Then
            Exit For
        End If
        
        iTmp = i * 100 / UBound(aTmp)
        If iProgress <> iTmp Then
            iProgress = iTmp
            RaiseEvent Progress(iProgress)
        End If
            
    Next i
    
    Erase sLine
    
    'ctrl.TextRTF = rtfText & "}"
    ctrl.TextRTF = m_oString.toString & "}"
    m_oString.Reset
    
End Sub

Private Sub HighLightLine(ByRef sLine As String)
'*扫描字符，输出格式化后的字符串
Dim i       As Long
Dim j       As Integer
Dim k       As Integer
Dim bComm As Boolean

    m_sWord = Split(sLine, " ")
    k = UBound(m_sWord)
    For i = 0 To k

        '*如果不是字符串，则进行先进行注释判断，再进行关键字判断
        If m_iQuotState = 0 Then
        
            bComm = TreatComment(m_sWord(i), (i = k))         '*处理注释
        
        End If

        If Not bComm Then

                If TreatQuot(m_sWord(i), (i = k), 1) Then       '*处理字符串
                
                    '*恢复被处理过的字符串标志
                    If m_sQuotFlag1 <> "" Then
                        m_sWord(i) = Replace(m_sWord(i), Chr(1), m_sQuotFlag1)
                    End If
                    If m_sQuotFlag2 <> "" Then
                        m_sWord(i) = Replace(m_sWord(i), Chr(2), m_sQuotFlag2)
                    End If
                Else
                
                    If m_iQuotState = 0 Then
                        Call TreatKeyWord(m_sWord(i))         '*处理关键字
                    End If
                    
                End If

        End If
        If i <> k Then m_sWord(i) = m_sWord(i) & " "
        
    Next i
    
    sLine = Join(m_sWord, "")

End Sub

Private Function TreatComment(ByRef sWord As String, ByVal bLast As Boolean) As Boolean
'*处理注释
'*      bLast       --是否最后一个字符
'*      返回值：    sWord是否注释
    Select Case m_iCommState
        Case 0
            If m_sLnCommFlag1 <> "" Then
                If InStr(1, sWord, m_sLnCommFlag1, vbBinaryCompare) = 1 Then  '*是单行注释一
                    m_iCommState = 1
                    '*加上注释字体RTF格式头
                    sWord = m_sCommRtfHead & sWord
                    TreatComment = True
                    '*如果最后一行，再进行处理
                    If bLast Then
                        TreatComment sWord, True
                    End If
                    Exit Function
                End If
            End If
            If m_sLnCommFlag2 <> "" Then
                If InStr(1, sWord, m_sLnCommFlag2, vbBinaryCompare) = 1 Then  '*是单行注释二
                    m_iCommState = 2
                    '*加上注释字体RTF格式头
                    sWord = m_sCommRtfHead & sWord
                    TreatComment = True
                    '*如果最后一个词，再进行处理
                    If bLast Then
                        TreatComment sWord, True
                    End If
                    Exit Function
                End If
            End If
            If m_sBlkCommHead1 <> "" And m_sBlkCommFoot1 <> "" Then
                If InStr(1, sWord, m_sBlkCommHead1, vbBinaryCompare) = 1 Then  '*是多行注释一
                    m_iCommState = 3
                    '*加上注释字体RTF格式头
                    sWord = m_sCommRtfHead & sWord
                    TreatComment = True
                    TreatComment sWord, bLast
                    Exit Function
                End If
            End If
            If m_sBlkCommHead2 <> "" And m_sBlkCommFoot2 <> "" Then
                If InStr(1, sWord, m_sBlkCommHead2, vbBinaryCompare) = 1 Then '*是多行注释二
                    m_iCommState = 4
                    '*加上注释字体RTF格式头
                    sWord = m_sCommRtfHead & sWord
                    TreatComment = True
                    TreatComment sWord, bLast
                    Exit Function
                End If
            End If
        Case 1, 2
            TreatComment = True
            If bLast Then       '*单行注释，且当前为此行最后一个词，将注释标志恢复为0
                sWord = sWord & m_sCommRtfFoot
                m_iCommState = 0
            End If
        Case 3
            TreatComment = True
            If m_sBlkCommHead1 <> "" And m_sBlkCommFoot1 <> "" And Len(sWord) > 1 Then
                If InStrRev(sWord, m_sBlkCommFoot1, , vbBinaryCompare) <> 0 Then '*是多行注释一
                    m_iCommState = 0
                    '*加上注释字体RTF格式尾
                    sWord = sWord & m_sCommRtfFoot
                    Exit Function
                End If
            End If
        Case 4
            TreatComment = True
            If m_sBlkCommHead2 <> "" And m_sBlkCommFoot2 <> "" And Len(sWord) > 1 Then
                If InStrRev(sWord, m_sBlkCommFoot2, , vbBinaryCompare) <> 0 Then '*是多行注释二
                    m_iCommState = 0
                    '*加上注释字体RTF格式尾
                    sWord = sWord & m_sCommRtfFoot
                    Exit Function
                End If
            End If
        Case Else
        
    End Select
    
End Function

Private Function TreatKeyWord(ByRef sWord As String) As Boolean
'*处理关键字
'*      返回值：    sWord是否关键字
Dim i           As Integer
Dim bKeyWord    As Boolean
    '* 先处理是不是数字
    If IsNumeric(sWord) Then
        sWord = m_sNumRtfHead & sWord & m_sNumRtfFoot
        Exit Function
    End If
    
    For i = 1 To m_iKwdCount
        If m_bCase Then
            If (InStr(1, m_sKwdSet(i), Chr(3) & sWord & Chr(3), vbBinaryCompare) <> 0) Then
               bKeyWord = True
            End If
        Else
            If (InStr(1, m_sKwdSet(i), Chr(3) & UCase(sWord) & Chr(3), vbBinaryCompare) <> 0) Then
                bKeyWord = True
            End If
        End If
        
        If bKeyWord Then
            '*加上字体RTF格式的头尾于词两端
            sWord = m_sKwdRtfHead(i) & sWord & m_sKwdRtfFoot(i)
            TreatKeyWord = True
            Exit Function
        End If
    Next i
End Function

Private Function TreatQuot(ByRef sWord As String, ByVal bLast As Boolean, ByVal iBegin As Integer) As Boolean
'*处理字符串
'*      bLast       是否此行最后一个词
'*      iBegin      搜索位置
'*      返回值：    是否做过字符串处理
Dim i       As Integer
Dim j       As Integer
Dim sQuot   As String       '*当前用来判断的字符串边界符
    Select Case m_iQuotState
        Case 0
            '*判断哪种字符串标志先出现，使用先出现的字符串标志来决定字符串起始位置
            i = 0
            j = 0
            If m_sQuotFlag1 <> "" Then
                i = InStr(iBegin, sWord, m_sQuotFlag1, vbBinaryCompare)
            End If
            If m_sQuotFlag2 <> "" Then
                j = InStr(iBegin, sWord, m_sQuotFlag2, vbBinaryCompare)
            End If
            If i = 0 And j = 0 Then     '*没有字符串标志出现，不用判断
                Exit Function
            End If
            If (j = 0) Or (i <> 0 And i < j) Then
                sQuot = m_sQuotFlag1
            End If
            If (j <> 0 And j < i) Or (i = 0) Then
                sQuot = m_sQuotFlag2
            End If
        Case 1
            sQuot = m_sQuotFlag1
        Case 2
            sQuot = m_sQuotFlag2
        Case Else
    End Select
    
    '*查找当前的字符串标志
    i = InStr(iBegin, sWord, sQuot, vbBinaryCompare)
    
    '*如果前一个字符是敏感字符前缀，则此次查找无效
    If m_sEscape <> "" Then
        If i > 1 Then
            j = InStr(iBegin, sWord, m_sEscape)
            If j <> 0 And j = i - Len(m_sEscape) Then
                '*将此字符串标志屏避
                If sQuot = m_sQuotFlag1 Then
                    sWord = Replace(sWord, sQuot, Chr(1), , 1)
                Else
                    sWord = Replace(sWord, sQuot, Chr(2), , 1)
                End If
                TreatQuot = True
                '*继续递归处理
                Call TreatQuot(sWord, bLast, i + 1)
                Exit Function
            End If
        End If
    End If
    
    If i <> 0 Then
    
        TreatQuot = True
        
        '*格式化字符串
        If sQuot = m_sQuotFlag1 Then
            If m_iQuotState = 0 Then
                sWord = Replace(sWord, sQuot, m_sQuotRtfHead & Chr(1), , 1)
                m_iQuotState = 1
            Else
                sWord = Replace(sWord, sQuot, Chr(1) & m_sQuotRtfFoot, , 1)
                m_iQuotState = 0
            End If
        Else
            If m_iQuotState = 0 Then
                sWord = Replace(sWord, sQuot, m_sQuotRtfHead & Chr(2), , 1)
                m_iQuotState = 2
            Else
                sWord = Replace(sWord, sQuot, Chr(2) & m_sQuotRtfFoot, , 1)
                m_iQuotState = 0
            End If
        End If

        '*继续递归处理
        Call TreatQuot(sWord, bLast, i)
        
    Else
    
        '*如果已经没有了标志，但续行无效的情况下，当前这个词为最后一个时，强行结束
        If bLast And Not m_bMultiLine And m_iQuotState <> 0 Then
            sWord = sWord & m_sQuotRtfFoot
            m_iQuotState = 0
        End If
        
    End If

End Function