历经N天完成的作品,和大家分享一下.

本作品主使用了以下技术:
1.VB语法着色(核心功能,绝对原创)
2.监视剪贴板并自动替换(部分参考网络文章)
3.智能分析是否VB代码(原创,不过这个功能写的比较简单,所以智能程度不够,只是意思意思而已)
4.全局热键(部分参考网络文章)
5.托盘图标及Explorer崩溃后重建任务栏图标(部分参考网络文章)
6.一个封装了INI文件读写的类(原创)
7.自定义着色方案,支持着色方案导入导出(也算原创吧,不过这个没啥技术含量)

先来张图


下边是源码

压缩包内的CodeStyle文件夹内已经放了一个UBB的着色方案

希望大家提点意见

等静哥审核通过后再来几段效果代码

不错不错  支持版主!


太谦虚啦!

不错不错  支持版主!

看看效果
'VB语法高亮(by 永夜的极光) V1.03
Option Explicit

Private Type Record
  Pos As Integer
  iType As Integer
End Type
Private Rec() As Record
Private RecCount As Integer
Private RecMax As Integer
Private aWord$(), aLine$()


Public Function isKeyWord(str As String[color=Magenta]) As Boolean
  Dim[/color] i%
  For i = [color=Blue]0 To UBound([/color]aKeyWord)
    [color=Green]If StrComp([/color]str, aKeyWord(i), vbTextCompare) = 0 Then
      isKeyWord = True
      Exit Function
    End If
  Next
  isKeyWord = False
End Function

Public Function isSymbol(str As String[color=Magenta]) As Boolean
  Dim[/color] i%
  For i = [color=Blue]0 To UBound([/color]aSymbol)
    [color=Green]If StrComp([/color]str, aSymbol(i), vbTextCompare) = 0 Then
      isSymbol = True
      Exit Function
    End If
  Next
  isSymbol = False
End Function

Public Function isFunction(str As String[color=Magenta]) As Boolean
  Dim[/color] i%
  For i = [color=Blue]0 To UBound([/color]aFunction)
    [color=Green]If StrComp([/color]str, aFunction(i), vbTextCompare) = 0 Then
      isFunction = True
      Exit Function
    End If
  Next
  isFunction = False
End Function

Public Function Encode(str As String[color=Magenta]) As String
  If[/color] str = "" Then Exit Function
  ScanRTB str
  Dim s$, i%, j%, tmpS
  
  s = [color=MediumTurquoise]Left([/color]str, Rec([color=Blue]0).[/color]Pos - [color=Blue]1)[/color]
  If CodeType = HTML Then s = Replace(Replace(Replace(s, [color=DarkOliveGreen]"<", "&lt"),[/color] vbCrLf, [color=DarkOliveGreen]"<br>" &[/color] vbCrLf), [color=DarkOliveGreen]" ", "&nbsp;")[/color]
  
  For i = 0 To RecCount - 1
    If Rec(i).iType >= 0 Then
      If i Mod 2 [color=Magenta]= 1[/color] Then
        s = s & [color=MediumTurquoise]IIf([/color]Code(Rec(i).iType).Enable, Code(Rec(i).iType).[color=Green]End, "")[/color]
      Else
        s = s & [color=MediumTurquoise]IIf([/color]Code(Rec(i).iType).Enable, Code(Rec(i).iType).Start, [color=DarkOliveGreen]"")[/color]
      End If
      j = i
      While Rec(i + [color=Blue]1).[/color]iType < 0
        i = i + 1
      Wend
      tmpS = [color=MediumTurquoise]Mid([/color]str, Rec(j).Pos, Rec(i + [color=Blue]1).[/color]Pos - Rec(j).Pos)
      If CodeType = HTML Then tmpS = Replace(Replace(Replace(tmpS, [color=DarkOliveGreen]"<", "&lt"),[/color] vbCrLf, [color=DarkOliveGreen]"<br>" &[/color] vbCrLf), [color=DarkOliveGreen]" ", "&nbsp;")[/color]
      s = s & tmpS
    End If
  Next
  If Code(CGLOBAL).Enable = True Then
    Encode = Code(CGLOBAL).Start & s & Code(CGLOBAL).End
  Else
    Encode = s
  End If
End Function

Private Sub AddRecord(Pos As Integer, iType As Integer[color=Magenta])
  If[/color] RecCount = RecMax Then
    RecMax = RecMax + 1000
    ReDim Preserve Rec(RecMax)
  End If
  Rec(RecCount).Pos = Pos
  Rec(RecCount).iType = iType
  RecCount = RecCount + 1
End Sub

Private Sub ScanRecord()
  Dim ColorStack%()
  Dim i%, j%, LastPos%
  ReDim ColorStack(MAXCOLOR)
  For i = 0 To MAXCOLOR - 1
    ColorStack(i) = -1
  Next
  For i = 0 To RecCount - 2 Step 2
    If Code(Rec(i).iType).Enable = False Then
      For j = 0 To MAXCOLOR - 1
        ColorStack(j) = -1
      Next
    Else
      LastPos = ColorStack(Rec(i).iType)
      If LastPos = -1 Then
        ColorStack(Rec(i).iType) = i
      Else
        If Rec(LastPos + [color=Blue]1).[/color]iType = -1 Then
          Rec(Rec(LastPos + [color=Blue]1).[/color]Pos).iType = -1
        Else
          Rec(LastPos + [color=Blue]1).[/color]iType = -1
        End If
        Rec(LastPos + [color=Blue]1).[/color]Pos = i + 1
        Rec(i).iType = -1
        For j = 0 To MAXCOLOR - 1
          If ColorStack(j) > LastPos Then
            ColorStack(j) = -1
          End If
        Next
      End If
    End If
  Next
End Sub

Private Sub ScanRTB(str As String[color=Magenta])
  Dim[/color] Pos%, i%
  If str = "" Then Exit Sub
  RecCount = 0
  aLine = [color=MediumTurquoise]Split([/color]str, vbCrLf)
  Pos = 0
  ScanLine aLine([color=Blue]0),[/color] 0, 1
  For i = [color=Blue]1 To UBound([/color]aLine)
    Pos = [color=MediumTurquoise]InStr([/color]Pos + 1, str, vbCrLf)
    ScanLine aLine(i), Pos + 1, 1
  Next
  If CanNesting Then ScanRecord
  Rec(RecCount).Pos = [color=MediumTurquoise]Len([/color]str) + 1
  Rec(RecCount).iType = 0
End Sub

Private Sub ScanLine(str As String, Offset As Long, iStep As Integer[color=Magenta])
  Dim[/color] Pos1%, Pos2%, i%
  Select Case iStep
    Case 1:
      Pos1 = [color=MediumTurquoise]InStr([/color]1, str, [color=DarkOliveGreen]"'",[/color] vbTextCompare)
      If Pos1 <> 0 Then
        Dim c%
        c = 0
        Pos2 = [color=MediumTurquoise]InStr(1, Left([/color]str, Pos1 - [color=Blue]1), """",[/color] vbTextCompare)
        While Pos2 <> 0
          c = c + 1
          Pos2 = [color=MediumTurquoise]InStr([/color]Pos2 + [color=Blue]1, Left([/color]str, Pos1 - [color=Blue]1), """",[/color] vbTextCompare)
        Wend
        If c Mod 2 [color=Magenta]= 1[/color] Then
          Pos1 = [color=MediumTurquoise]InStr([/color]Pos1, str, [color=DarkOliveGreen]"""",[/color] vbTextCompare)
          ScanLine Left(str, Pos1), Offset, 2
          ScanLine Mid(str, Pos1 + [color=Blue]1),[/color] Offset + Pos1, 1
        Else
          ScanLine Left(str, Pos1 - [color=Blue]1),[/color] Offset, 2 '
          AddRecord Offset + Pos1, CCOMMENT
          AddRecord Offset + [color=MediumTurquoise]Len([/color]str) + 1, CCOMMENT
        End If
      Else
        ScanLine str, Offset, [color=Blue]2
      [color=Green]End If
    Case 2[/color]:[/color]
      If str = "" Then
        Exit Sub
      End If
      Pos1 = [color=MediumTurquoise]InStr([/color]1, str, [color=DarkOliveGreen]"""",[/color] vbTextCompare)
      If Pos1 <> 0 Then
        If Pos1 <> 1 Then
          ScanLine Left(str, Pos1 - [color=Blue]1),[/color] Offset, 3
        End If
        Pos2 = [color=MediumTurquoise]InStr([/color]Pos1 + 1, str, [color=DarkOliveGreen]"""",[/color] vbTextCompare)
        AddRecord Offset + Pos1, CSTRING
        AddRecord Offset + Pos2 + 1, CSTRING
        ScanLine Mid(str, Pos2 + [color=Blue]1),[/color] Offset + Pos2, 2
      Else
        ScanLine str, Offset, [color=Blue]3
      [color=Green]End If
    Case 3[/color]:[/color]
      If str = "" Then
        Exit Sub
      End If
      aWord = [color=MediumTurquoise]Split([/color]str, [color=DarkOliveGreen]" ")[/color]
      Pos1 = 0
      ScanLine aWord([color=Blue]0),[/color] Offset, 4
      For i = [color=Blue]1 To UBound([/color]aWord)
        Pos1 = [color=MediumTurquoise]InStr([/color]Pos1 + 1, str, [color=DarkOliveGreen]" ")[/color]
        ScanLine aWord(i), Offset + Pos1, [color=Blue]4
      [color=Green]Next
    Case 4[/color]:[/color]
      If str = "" Then
        Exit Sub
      End If
      Pos1 = [color=MediumTurquoise]InStr([/color]1, str, [color=DarkOliveGreen]".")[/color]
      If Pos1 > 1 Then
        If IsNumeric([color=MediumTurquoise]Mid([/color]str, Pos1 - [color=Blue]1, 1))[/color] And IsNumeric([color=MediumTurquoise]Mid([/color]Pos1 + [color=Blue]1, 1))[/color] Then
          ScanLine str, Offset, 5
        Else
          ScanLine Left(str, Pos1 - [color=Blue]1),[/color] Offset, 5
          AddRecord Offset + Pos1, CSYMBOL
          AddRecord Offset + Pos1 + 1, CSYMBOL
          ScanLine Mid(str, Pos1 + [color=Blue]1),[/color] Offset + Pos1, 4
        End If
      ElseIf Pos1 = 1 Then
        AddRecord Offset + Pos1, CSYMBOL
        AddRecord Offset + Pos1 + 1, CSYMBOL
        ScanLine Mid(str, Pos1 + [color=Blue]1),[/color] Offset + Pos1, 4
      Else
        ScanLine str, Offset, [color=Blue]5
      [color=Green]End If
         
    Case 5[/color]:[/color]
      If str = "" Then
        Exit Sub
      End If
      If IsNumeric(str) Then
        AddRecord Offset + 1, CNUMBER
        AddRecord Offset + [color=MediumTurquoise]Len([/color]str) + 1, CNUMBER
        Exit Sub
      End If
      For i = [color=Blue]0 To UBound([/color]aSymbol)
        Pos1 = [color=MediumTurquoise]InStr([/color]1, str, aSymbol(i))
        If Pos1 <> 0 Then '如果包含
          ScanLine Left(str, Pos1 - [color=Blue]1),[/color] Offset, 5
          AddRecord Offset + Pos1, CSYMBOL
          AddRecord Offset + Pos1 + [color=MediumTurquoise]Len([/color]aSymbol(i)), CSYMBOL
          ScanLine Mid(str, Pos1 + [color=MediumTurquoise]Len([/color]aSymbol(i))), Offset + Pos1 + [color=MediumTurquoise]Len([/color]aSymbol(i)) - 1, 5
          Exit Sub
        End If
      Next
      ScanLine str, Offset, [color=Blue]6
    [color=Green]Case 6[/color]:[/color]
      If str = "" Then
        Exit Sub
      End If
      If str = "_" Then
        AddRecord Offset + 1, CSYMBOL
        AddRecord Offset + [color=MediumTurquoise]Len([/color]str) + 1, CSYMBOL
      ElseIf IsNumeric(str) Then
        AddRecord Offset + 1, CNUMBER
        AddRecord Offset + [color=MediumTurquoise]Len([/color]str) + 1, CNUMBER
      ElseIf isFunction(str) Then
        AddRecord Offset + 1, CFUNCTION
        AddRecord Offset + [color=MediumTurquoise]Len([/color]str) + 1, CFUNCTION
      ElseIf isKeyWord(str) Then
        AddRecord Offset + 1, CKEYWORD
        AddRecord Offset + [color=MediumTurquoise]Len([/color]str) + 1, CKEYWORD
      Else
        AddRecord Offset + 1, CNORMAL
        AddRecord Offset + [color=MediumTurquoise]Len([/color]str) + 1, CNORMAL
      End If
    Case Else:
      Debug.Print "Error Step"
  End Select
End Sub

这几个函数就是语法分析的核心算法啦

Public Function Encode(str As String) As String
总的对外接口

Private Sub ScanRTB(str As String)
本来是没有监视剪贴板功能的，需要高亮的代码放在RichTextBox里面，所以就叫了这么个函数名字，后来把RichTextBox去掉了，这个函数名也不知道叫什么好，就没改了

Private Sub ScanLine(str As String, Offset As Long, iStep As Integer)
逐行分析，这个就是核心的核心啦。类似于二叉树的形式

Private Sub ScanRecord()
这个函数是为了合并一些可以合并的标签

顶!
以后发代码就不用自己写代码做高亮啦~!

三断笛看看有啥BUG没，估计还是有不少的

呵呵 你的代码我有时间可还得好好研究一下呢  比我写的规范多了  很多地方都值得学习      这样的好作品得顶起来呀!

BUG还没发现  没仔细去读代码  不过在运行这个程序的时候再打开VB,有时候会弹出作用于某某方法失败的提示     



好帖,顶呀!!!!!!!!!!

樓主辛苦了

LZ我的是繁體系統可否給個繁體的,到我這邊是亂碼啊,謝了