【VB】论ide部分功能的实现（语法高亮），（智能感知）

cyycoish 发表于 2014-12-19 22:31:35

Oklet us start!
本贴讨论ide编辑器的两个功能：一个是Highlighting（语法高亮），另一个是Intellisence（智能感知）{以下简称：IS}
=====================================================================================================================
好，先看IS
以一款vbs编辑器为例，vbs功能之所以强大，是因为它可以调用com，windows提供了种类丰富，功能强大的各类com组件
com组件种类繁多，让我们眼花缭乱，一款好的编辑器应该提供com组件的属性与方法来便于我们编程
那么问题来了：如何实现?
1.我们可以把所有com组件的所有属性与方法存进类数据库文件，在编辑时进行调用
2.我们可以获取系统注册的com组件的信息，scan com组件字符串，然后筛选调用
就上述两种方法，大家可以讨论，第一种繁琐，而且不是dynamic，显然应该使用方法2
所以关键技术放在了如何与系统的com组件注册机制获得connection
好的，这里就引出typelib infomation，如图：
Dim i As Integer
Dim oTLB As InterfaceInfo
Dim tar As Object
Set tar = CreateObject(objectName)
Set oTLB = tli.InterfaceInfoFromObject(tar)
listA.Clear
For i = 1 To oTLB.Members.Count
   Select Case oTLB.Members(i).InvokeKind
   Case INVOKE_CONST
         listA.AddItem "常数:" & oTLB.Members(i).Name
   Case INVOKE_EVENTFUNC
         listA.AddItem "事件:" & oTLB.Members(i).Name
   Case INVOKE_FUNC
         listA.AddItem "方法:" & oTLB.Members(i).Name
   Case INVOKE_PROPERTYGET
         listA.AddItem "属性(Get):" & oTLB.Members(i).Name
   Case INVOKE_PROPERTYPUT
         listA.AddItem "属性(Let):" & oTLB.Members(i).Name
   Case INVOKE_PROPERTYPUTREF
         listA.AddItem "属性(Set):" & oTLB.Members(i).Name
   Case INVOKE_UNKNOWN
         listA.AddItem "未知:" & oTLB.Members(i).Name
   End Select
Next
tar即为目标com组件，先创建名为tar的com对象
然后用tli库的InterfaceInfoFromObject方法获得com对象
利用i计数器和oTLB.Members.Count控制循环，获取该com组件在系统内注册的信息
那么INVOKE_CONST即为常数INVOKE_EVENTFUNC为事件INVOKE_FUNC为方法等等。。
好了，至此我们将信息录入listbox，下面只要让listbox跟踪插入符的移动，便可以做出以我乱VS（出自于：以假乱真）的IS啦
那么具体在vb6的方法实现是，将form或者一个picture的font属性设置得和richtextbox一样，用“TextWidth（列数）”方法计算listbox的left
用TextHeight（当前行-显示的首行）计算listbox的top，那么关于获得编辑文本框的光标行列，显示之首行等信息，我已经封装成一个模块，大家可以在这里下载（源码同样包含）：
继续，关于如何搜索com组件的关键字，我是这样解决的：因为在vbs中引用com代码通常是这样的
dim a
set a = createobject("xxx.xxx")
a.
这里只要输出“.”即可弹出listbox，然后根据语法set 空格（n个）变量名（可能未声明）createobject括号字符串xxx.xxx（注意，这个语句可能出现在变量使用之上文的任意位置）获得这个xxx.xxx
然后取得类似变量名点的式子然后方法如上搜索属性方法，具体代码参见vbspad源码。
'这是我用来识别com组件连接字符串的代码：
Public Function ScanObjects(valName As String, cTextBox As RichTextBox)
Dim ts As String
Set objRegEx = New RegExp
With objRegEx
   .MultiLine = True
   .IgnoreCase = True
   .Global = True
End With
'Dim matchStr As String
Dim eXMatCol As MatchCollection, eXMat As Match

objRegEx.Pattern = "set\s*" & valName & "\s*=\s*createobject\s*\(" & Chr(34) & ".*" & Chr(34) & "\)"
If objRegEx.Test(cTextBox.Text) Then
   Set eXMatCol = objRegEx.Execute(cTextBox.Text)
   Set eXMat = eXMatCol.Item(eXMatCol.Count - 1)

   ts = eXMat.Value
   objRegEx.Pattern = Chr(34) & ".*" & Chr(34)
   If objRegEx.Test(ts) Then
         Set eXMatCol = objRegEx.Execute(cTextBox.Text)
         Set eXMat = eXMatCol.Item(eXMatCol.Count - 1)
         ScanObjects = Replace(eXMat.Value, Chr(34), vbNullString)
         Exit Function
   End If
End If
End Function
那么关于字符串的匹配与搜索呢，我是这样想的，例如，有com组件xxx.xxx,其下有方法abc整形参数一个
dim var
set var = createobject("xxx.xxx")
var.abc(1)
那么listbox里边一定会列出abc
我们即可在richtextbox的keypress事件中监测键码“上键”和“下键”，检测到将listbox setfocus，同时，listbox监测键码空格（32）回车（13）将listbox中的内容copy到richtextbox中
最后richtextbox.setfocus，list.visible=false
'这段代码用来检测变量
Public Function GetVarName(cTextBox As RichTextBox)
Dim ts1 As String
Dim eXMatCol As MatchCollection, eXMat As Match
ts1 = GetLineText(cTextBox, GetCurPos(cTextBox).Y - 1)

Set objRegEx = New RegExp
With objRegEx
   .MultiLine = True
   .IgnoreCase = True
   .Global = True
End With

objRegEx.Pattern = "\w*\."
If objRegEx.Test(cTextBox.Text) Then
   Set eXMatCol = objRegEx.Execute(cTextBox.Text)
   Set eXMat = eXMatCol.Item(eXMatCol.Count - 1)

   GetVarName = Replace(eXMat.Value, ".", vbNullString)
   Exit Function
End If
End Function
搜索同名属性方法：
Private Sub ScanListWords()
Dim i As Integer
For i = 0 To List1.ListCount - 1
If InStr(1, LCase(List1.List(i)), LCase(pStr)) <> 0 The
List1.ListIndex = i
End If
Next
End Sub

好了，IS告一段落下面该讲讲语法高亮了
=================================================================================================================================================================================================
语法高亮，实在是伟大的发明，它能让满眼乱七八糟的数字与符号看起来富有意义
关于vb实现语法高亮，最容易想到的便是richtextbox（简称：rtb）控件
但是呢rtb在对大量代码染色时速度很慢，不过我还是决定试一试
说到rtb的染色，rtb上色有两种办法（不说子类化重绘，我没有尝试过子类化重绘）：
1.配合使用selstart，sellenth，selcolor属性（我给他起个名字叫：三属性渲染）。2.使用rtb格式化文档（我尝试失败）
那么咱们讲讲三属性渲染：
对于rtb控件的染色提速有以下几点方法：
1.加载时全部染色（很耗时），然后对于正在编辑的行，进行单独染色（初始全染，编辑分染）
2.对于显示的多行进行染色，当显示首行有变动，用timer监测变动及时补染。对于正在编辑的行，再单独染色（分时分段渲染，编辑分染）
由于vbspad也属于早起开发的工具，在当时，我采用了“初始全染，编辑分染”的方法，虽然方法2效率更高。
那么对于关键字的识别，主要还是用到了正则表达式。
关于正则，笔者不赘述，大家可以参考这篇文档（版权归原作者所有，仅供学习交流，本人不负任何责任）：
那么在我的源码中，正则匹配部分位于Module2中：
Option Explicit

Dim objRegEx As RegExp
Dim aRWord() As String
Dim aFWord() As String
Dim aOWord() As String

Public Sub InitHighLig()
aRWord = Split("Call|Case|Class|Const|Debug|Dim|Do|Each|Else|ElseIf|Empty|End|End If|End With|End Sub|End Function|Eqv|Exit Function|Exit Sub|Exit For|Exit Do|Exit While|Error|Err|False|For|Function|Get|Goto|If|Imp|In|Is|Let|Loop|New|Next|Nothing|Null|On|Option|Preserve|Private|Public|ReDim|Rem|Resume|Select|Set|Sub|Then|To|True|Until|WEnd|While|With", "|")
aFWord = Split("Abs|Array|Asc|Atn|CBool|CByte|CCur|CDate|CDbl|Chr|CInt|CLng|Cos|CreateObject|CSng|CStr|Date|DateAdd|DateDiff|DatePart|DateSerial|DateValue|Day|Eval|Exp|Filter|Fix|FormatCurrency|FormatDateTime|FormatNumber|FormatPercent|GetLocale|GetObject|GetRef|Hex|Hour|InputBox|InStr|InStrRev|Int|IsArray|IsDate|IsEmpty|IsNull|IsNumeric|IsObject|Join|LBound|LCase|Left|Len|LoadPicture|Log|LTrim|Mid|Minute|Month|MonthName|MsgBox|Now|Oct|Replace|RGB|Right|Rnd|Round|RTrim|ScriptEngine|ScriptEngineBuildVersion|ScriptEngineMajorVersion|ScriptEngineMinorVersion|Second|SetLocale|Sgn|Sin|Space|Split|Sqr|StrComp|String|StrReverse|Tan|Time|Timer|TimeSerial|TimeValue|Trim|TypeName|UBound|UCase|VarType|Weekday|WeekdayName|Year", "|")
aOWord = Split(">|<|=|+|-|*|/|^|Mod|Not|And|Or|Xor", "|")
Set objRegEx = New RegExp
With objRegEx
   .MultiLine = False
   .IgnoreCase = True
   .Global = True
End With
End Sub

Public Sub HigLigCurLnB(tB As RichTextBox, rTBSSt As Long, Optional ln As Long)
On Error GoTo EH_HLCL:
Dim sRWords As String, aRWords() As String
Dim rST As Long
sRWords = "dim |option explicit|if | then|else|end if|do|loop|"
aRWords = Split(sRWords, "|")
rST = tB.SelStart
Dim t As Variant
For Each t In aRWords
   If InStrRev(LCase(tB.Text), t, rTBSSt) Then
         tB.SelStart = tB.SelStart - Len(t)
         tB.SelLength = Len(t)
         tB.SelColor = &HFF0000
         tB.SelLength = 0
         tB.SelColor = &H0&
         tB.SelStart = rST
         tB.SelColor = &H0&
         Exit For
   End If
Next
EH_HLCL:
If Err <> 0 Then
   tB.SelLength = 0
   tB.SelColor = &H0&
End If
End Sub

Public Function FormatCurCode(ln As Long)
'If a Then a = 3

End Function
Public Sub HigLigCurLnC(cTextBox As RichTextBox, lnSelectionStart As Long, Optional ln As Long)
Dim s1 As String
Dim st As String
Dim i As Integer
With cTextBox
   If GetCurPos(cTextBox).Y = 1 Then
         st = Mid(.Text, InStrRev(Mid(.Text, 1, lnSelectionStart), vbCrLf) + 1)
   Else
         st = Mid(.Text, InStrRev(Mid(.Text, 1, lnSelectionStart), vbCrLf) + 2)
   End If

   MsgBox Chr(34) & st & """"
   i = Len(st)
   Do While i <= 1
         's1 = Mid(st, i,
         If IsRWord(s1) = True Then
            .SelStart = lnSelectionStart - i
            .SelLength = Len(s1)
            .SelColor = &HFF0000
            i = i - Len(s1)
         End If
   Loop
   .SelLength = 0
   .SelStart = lnSelectionStart
   .SelColor = &H0&
End With
End Sub

Public Sub HigLigCurLn(cTextBox As RichTextBox, lnSelectionStart As Long, Optional colorAll As Boolean = False)
Dim st1 As String
Dim t As Variant, i As Integer
Dim fPos As Integer, rPos As Long
Dim eXMatCol As MatchCollection, eXMat As Match
rPos = lnSelectionStart

st1 = GetLineText(cTextBox, GetCurPos(cTextBox).Y - 1)
If colorAll = True Then st1 = cTextBox.Text
If colorAll = False Then
   With cTextBox
         If lnSelectionStart <= (GetCurPos(cTextBox).X - 1) Then
            .SelStart = .SelStart - ((GetCurPos(cTextBox).X - 1) - lnSelectionStart)
         Else
            .SelStart = .SelStart + (lnSelectionStart - (GetCurPos(cTextBox).X - 1))
         End If
         .SelLength = Len(st1) - 2
         .SelColor = &H0&
   End With
End If

For Each t In aRWord()
   objRegEx.Pattern = "\b" & t & "\b"
   If objRegEx.Test(st1) Then
         Set eXMatCol = objRegEx.Execute(st1)
         'MsgBox eXMatCol.Count

         For i = 0 To eXMatCol.Count - 1
            Set eXMat = eXMatCol.Item(i)
            fPos = eXMat.FirstIndex
            With cTextBox
               'MsgBox "fpos:" & fPos & vbCrLf & "cpos:" & GetCurPos(cTextBox).x - 1 '====
               If fPos <= GetCurPos(cTextBox).X - 1 Then
                     .SelStart = .SelStart - ((GetCurPos(cTextBox).X - 1) - fPos)
               Else
                     .SelStart = .SelStart + (fPos - (GetCurPos(cTextBox).X - 1))
               End If
               .SelLength = eXMatCol(0).Length
               .SelColor = &HFF0000
               '.SelColor = vbRed
               .SelText = objRegEx.Replace(.SelText, t)
            End With
         Next
   End If
Next
For Each t In aFWord()
   objRegEx.Pattern = "\b" & t & "\b"
   If objRegEx.Test(st1) Then
         Set eXMatCol = objRegEx.Execute(st1)
         For i = 0 To eXMatCol.Count - 1
            Set eXMat = eXMatCol.Item(i)
            fPos = eXMat.FirstIndex
            With cTextBox
               If fPos <= GetCurPos(cTextBox).X - 1 Then
                     .SelStart = .SelStart - ((GetCurPos(cTextBox).X - 1) - fPos)
               Else
                     .SelStart = .SelStart + (fPos - (GetCurPos(cTextBox).X - 1))
               End If
               .SelLength = eXMatCol(0).Length
               .SelColor = &HC000C0
               .SelText = objRegEx.Replace(.SelText, t)
            End With
         Next
   End If
Next
For Each t In aOWord()
   Select Case t
   Case "Mod", "Not", "And", "Or", "Xor"
         objRegEx.Pattern = "\b" & t & "\b"
   Case ">", "<", "=", "^", "-", "/"
         objRegEx.Pattern = t
   Case "+", "*"
         objRegEx.Pattern = "\" & t
   End Select

   If objRegEx.Test(st1) Then
         Set eXMatCol = objRegEx.Execute(st1)
         For i = 0 To eXMatCol.Count - 1
            Set eXMat = eXMatCol.Item(i)
            fPos = eXMat.FirstIndex
            With cTextBox
               If fPos <= GetCurPos(cTextBox).X - 1 Then
                     .SelStart = .SelStart - ((GetCurPos(cTextBox).X - 1) - fPos)
               Else
                     .SelStart = .SelStart + (fPos - (GetCurPos(cTextBox).X - 1))
               End If
               .SelLength = eXMatCol(0).Length
               .SelColor = &H80FF&
               If t = "Mod" Or t = "Not" Or t = "And" Or t = "Or" Or t = "Xor" Then .SelText = objRegEx.Replace(.SelText, t)
            End With
         Next
   End If
Next
'字符串
objRegEx.Pattern = Chr(34) & ".*" & Chr(34)
If objRegEx.Test(st1) Then
   Set eXMatCol = objRegEx.Execute(st1)
   For i = 0 To eXMatCol.Count - 1
         Set eXMat = eXMatCol.Item(i)
         fPos = eXMat.FirstIndex
         With cTextBox
            If fPos <= GetCurPos(cTextBox).X - 1 Then
               .SelStart = .SelStart - ((GetCurPos(cTextBox).X - 1) - fPos)
            Else
               .SelStart = .SelStart + (fPos - (GetCurPos(cTextBox).X - 1))
            End If
            .SelLength = eXMatCol(0).Length
            .SelColor = &H808080
         End With
   Next
End If
'注释
objRegEx.Pattern = "'\w*"
If objRegEx.Test(st1) Then
   Set eXMatCol = objRegEx.Execute(st1)
   Set eXMat = eXMatCol.Item(0)
   fPos = eXMat.FirstIndex
   With cTextBox
         If fPos <= GetCurPos(cTextBox).X - 1 Then
            .SelStart = .SelStart - ((GetCurPos(cTextBox).X - 1) - fPos)
         Else
            .SelStart = .SelStart + (fPos - (GetCurPos(cTextBox).X - 1))
         End If
         .SelLength = eXMatCol(0).Length
         .SelColor = &HC000&
   End With
End If

With cTextBox
   .SelStart = rPos
   .SelLength = 0
   .SelColor = &H0&
End With
End Sub

Private Function IsRWord(wordText As String) As Boolean
Dim t As Variant
IsRWord = False
For Each t In aRWord()
   If LCase(wordText) = LCase(t) Then
         IsRWord = True
         Exit Function
   End If
Next
End Function

这是vbspad的源码，bug有很多，请大家谅解：
==============================================================================================================================================================================================
结语：
方法是人想出来的，路是人踩出来的，条条大路通罗马，种种方法能解题。以上是鄙人的一点拙见，仅供大家参考。
时至今日，鄙人还在编译原理和人工智能的道路上奋进。世界的发展靠的是人的联系，谨希望同大家共勉，多多交流沟通。
一个人的奋斗也离不开千千万万朋友的帮助，这里特别感谢站长@0xAA55 ，还有@tesla.angela 没有他们的支持，我很难走到今天。

0xAA55 发表于 2014-12-19 22:42:02

哈哈你这个看着效果真是赞！

Golden Blonde 发表于 2014-12-19 22:42:52

没有横向滚动条，没有菜单。。。还有主界面无需使用自定义吧！

cyycoish 发表于 2014-12-19 23:34:54

@美俪女神{:soso_e113:}

imr2013 发表于 2022-11-23 21:57:18

非常棒！

W741 发表于 2022-11-29 17:46:52

在win10 里面行号显示有问题，还有关键字提示不会出来

liu496324 发表于 2023-7-6 11:01:29

很好，试一下

页: [1]

技术宅的结界's Archiver

【VB】论ide部分功能的实现（语法高亮），（智能感知）