文本无限制撤消的VB代码

VB编写的记事本之类的程序，多是用text控件和RichTextBox控件，它们的编辑功能笔者一般都是用API函数SendMessage来实现，基本上能满足要求。但不爽的是，只能撤消一次，要想无限制撤消，就要另想办法。为此，笔者编写了下面的代码来解决这个问题。
在窗体上添加一个RichTextBox控件，一个标签控件，并根据以下代码自行添加菜单（可以用按纽代替，但右键菜单就没有了）。
代码如下：

Option Explicit

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Dim undoSt() As String  '用于撤消的文本
Dim undoID As Integer   '可撤消次数
Dim curPos As Long      '光标位置

Private Sub Form_Load()
ReDim undoSt(0)
End Sub

Private Sub CmdNew_Click()
RichTextBox1.Text = ""
Me.Caption = ""
undoPurge
End Sub

Private Sub CmdOpen_Click()
On Error GoTo 100
Dim Dlg As Object, openName As String
Set Dlg = CreateObject("MSComDlg.CommonDialog")

With Dlg
  .DialogTitle = "打开"
  .Flags = &H1000
  .CancelError = True
  .Filter = "txt或rtf文件|*.txt;*.rtf"
  .showopen
  openName = LCase(.FileName)
End With
If Len(openName) < 8 Then Exit Sub

RichTextBox1.LoadFile openName
Me.Caption = openName
ndoPurge

100
End Sub

Private Sub CmdSave_Click()
On Error GoTo 100
Dim Dlg As Object, saveName As String
Set Dlg = CreateObject("MSComDlg.CommonDialog")

With Dlg
  .DialogTitle = "保存"
  .Flags = &H802
  .CancelError = True
  .Filter = "TXT文档|*.txt|RTF文档|*.rtf"
  .showsave
  saveName = LCase(.FileName)
End With
If Len(saveName) < 8 Then Exit Sub

If Dlg.FilterIndex = 1 Then
  Open saveName For Output As #2
  Print #2, RichTextBox1.Text
  Close #2
Else
  RichTextBox1.SaveFile saveName
End If

undoPurge
Me.Caption = saveName

100
End Sub

Private Sub CmdCut_Click() '剪切
undoChange RichTextBox1.SelText, 0
SendMessage RichTextBox1.hWnd, 768, 0, 0
End Sub

Private Sub CmdDel_Click() '删除
undoChange RichTextBox1.SelText, 0
SendMessage RichTextBox1.hWnd, 771, 0, 0
End Sub

Private Sub CmdCopy_Click() '复制
SendMessage RichTextBox1.hWnd, 769, 0, 0
End Sub

Private Sub CmdPaste_Click() '粘贴
Dim st As String, j As Long
j = Len(Clipboard.GetText)
If RichTextBox1.SelLength = 0 Then '如果是直接粘贴
  SendMessage RichTextBox1.hWnd, 770, 0, 0
  curPos = RichTextBox1.SelStart - j
  undoChange Right("00000" & Format(j), 6), 1 '把粘贴长度转换为6字节字符串
Else '如果先用鼠标选定一段文本粘贴
  st = RichTextBox1.SelText
  SendMessage RichTextBox1.hWnd, 770, 0, 0
  curPos = RichTextBox1.SelStart - j
  undoChange Right("00000" & Format(j), 6) & "，" & st, 2
End If
End Sub

Private Sub CmdUndo_Click() '撤消
If undoID = 0 Then MsgBox "没有可撤消的文本": Exit Sub
Dim uMode As Integer '撤消模式：0-原操作为删除，1-原操作为粘贴，2-原操作为选定文本删除并粘贴
Dim curPos2 As Long
Dim st As String

undoID = undoID - 1
Label1 = undoID
curPos2 = Val(Left(undoSt(undoID), 6))
RichTextBox1.SelStart = curPos2   '光标定位
uMode = Mid(undoSt(undoID), 7, 1) '获得撤消模式
st = Mid(undoSt(undoID), 8)       '获得撤消内容
ReDim Preserve undoSt(undoID)

Select Case uMode
  Case 0
    RichTextBox1.SelText = st
    RichTextBox1.SelStart = curPos2  '反相显示
    RichTextBox1.SelLength = Len(st) '反相显示
  Case 1
    RichTextBox1.SelLength = Val(st)
    RichTextBox1.SelText = ""
  Case 2
    RichTextBox1.SelLength = Val(st)
    st = Mid(st, 8)
    RichTextBox1.SelText = st
    RichTextBox1.SelStart = curPos2  '反相显示
    RichTextBox1.SelLength = Len(st) '反相显示
End Select
End Sub

Private Sub CmdSwap_Click(Index As Integer) '替换和全部替换
Dim findSt As String, swapSt As String, sCount As Long, i As Long

If RichTextBox1.SelLength = 0 Then '如果没有用鼠标选定一段文本
  findSt = InputBox$("输入要查询的字串"): If Len(findSt) = 0 Then Exit Sub
Else
  findSt = RichTextBox1.SelText
End If
swapSt = InputBox$("输入要替换的字串"): If Len(swapSt) = 0 Then Exit Sub

Do
  i = RichTextBox1.Find(findSt, i): If i = -1 Then Exit Do
  RichTextBox1.SelText = swapSt
  curPos = i
  undoChange Right("00000" & Len(swapSt), 6) & "，" & findSt, 2
  sCount = sCount + 1
  If Index = 0 Then If MsgBox("已经替换了" & sCount & "次，是否继续？", 4) = 7 Then Exit Do
  i = i + 1
Loop Until i >= Len(RichTextBox1.Text)

MsgBox "共替换了" & sCount & "次"
End Sub

Private Sub RichTextBox1_SelChange()
curPos = RichTextBox1.SelStart
End Sub

Private Sub RichTextBox1_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = 32 Or KeyCode > 48 Then undoPurge '如果是键盘打字，清除撤消变量
End Sub

Private Sub RichTextBox1_KeyDown(KeyCode As Integer, Shift As Integer) '快捷键
Select Case Shift
  Case 0
    If KeyCode = 46 Or KeyCode = 8 Then '按下删除键或退格键
      If RichTextBox1.SelLength = 0 Then
        curPos = RichTextBox1.SelStart - IIf(KeyCode = 8, 1, 0)
        undoChange Mid(RichTextBox1.Text, curPos + 1, 1), 0 '删除一个字符
      Else
        undoChange RichTextBox1.SelText, 0 '先选定内容再删除
      End If
    End If
  Case 2 '先按下【Ctrl】键
    Select Case KeyCode
      Case 67: CmdCopy_Click   'C-复制
      Case 72: CmdSwap_Click 0 'H-替换
      Case 73: CmdSwap_Click 1 'I-全部替换
      Case 78: CmdNew_Click    'N-新建
      Case 79: CmdOpen_Click   'O-打开
      Case 83: CmdSave_Click   'S-保存
      Case 86: CmdPaste_Click  'V-粘贴
      Case 88: CmdCut_Click    'X-剪切
      Case 90: CmdUndo_Click   'Z-撤消
    End Select
End Select
End Sub