回 帖 发 新 帖 刷新版面

主题:文本无限制撤消的VB代码

文本无限制撤消的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


回复列表 (共4个回复)

沙发


Private Sub RichTextBox1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 2 Then PopupMenu Edit '调出右键菜单
End Sub

Private Sub Label1_DblClick()
undoPurge
End Sub

Private Sub undoChange(st As String, uMode As Integer)
undoSt(undoID) = Right("00000" & curPos, 6) & uMode & st '把6位数光标位置、撤消模式、字符串编组到一起
undoID = undoID + 1
ReDim Preserve undoSt(undoID)
Label1 = undoID
End Sub

Private Sub undoPurge()
ReDim undoSt(0)
undoID = 0
Label1 = 0
End Sub


简要分析:
代码中的标签控件用于显示可撤消次数,以及清零。
字符串一维数组undoSt供撤消之用,它由三部分组成:编辑前的光标位置、撤消模式、字符串。第三部分的字符串组成又分为三种情况:①如果原操作是删除,这就是被删除的字符串,这时撤消模式为0;②如果原操作是粘贴,这就是粘贴内容的长度值,这时撤消模式为1;③如果原操作是先用鼠标选定一段文本后再粘贴,这就是粘贴内容的长度值+鼠标选定的文本字符串(用中文逗号分隔),这时撤消模式为2。
整形变量undoID记录可撤消次数,当用户双击标签,或者新建、打开、保存文档后,或者用键盘打字后,数组和这个变量都清零。编辑是指菜单项的删除、剪切、粘贴,以及使用删除键和退格键。特别要注意,一旦用键盘打字,会将撤消数据全部清零,这也是没办法的事,因为用键盘打英文可以检测出来,但是打汉字检测不到,无法获取汉字串和汉字串的长度,而这两点正是撤消数据所必需的。
按下删除键(或退格键)后的处理有两种情况:①先用鼠标选定了一段文本,再按下删除键(或退格键),这比点击编辑菜单中的删除项速度更快,更方便;②不选定文本,就直接按下删除键(或退格键)一个个字符删除。这两种情况必须用不同的代码来处理。
替换时,可以直接点击鼠标右键,会弹出两次对话框,分别输入查找字符串和替换字符串。也可以先用鼠标选定一段文本作为查找字符串,再点击鼠标右键,只弹出一次对话框输入替换字符串即可。
本代码在32位Window7旗舰版上通过。

可到163信箱去下载工程附件,帐号:vb62013,密码:vb620132013


板凳

RichTextBox1_KeyUp过程做如下更改:


Private Sub RichTextBox1_KeyUp(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
  Case 32, 48 To 111, 186, 192, 229: undoPurge '如果键盘打字为可见字符,清除撤消变量
End Select
End Sub

3 楼

以上的代码中,笔者漏掉了一个编辑方法:当RichTextBox控件的属性OLEDropMode=2时,可以用鼠标选定一段文本再拖放到窗口内任意地方(把剪切和粘贴两个操作合二为一了),这应当也可以撤消,所以笔者补写了几句代码,各位自行插到原代码中去吧。

Option Explicit

Dim curPos4 As Long     '鼠标选定了一段文本时的光标位置

Private Sub CmdUndo_Click() '撤消
If undoID = 0 Then MsgBox "没有可撤消的文本": Exit Sub
Dim uMode As Integer '撤消模式:0-原操作为删除,1-原操作为粘贴,2-原操作为选定文本删除并粘贴,3-原操作为先用鼠标选定一段文本再拖放到别处
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) '反相显示
  Case 3
    curPos2 = Val(st)
    st = Mid(st, 8)
    RichTextBox1.SelLength = Len(st)
    RichTextBox1.SelText = ""
    RichTextBox1.SelStart = curPos2
    RichTextBox1.SelText = st
    RichTextBox1.SelStart = curPos2  '反相显示
    RichTextBox1.SelLength = Len(st) '反相显示
End Select
End Sub

Private Sub RichTextBox1_Change()
If RichTextBox1.SelLength Then undoChange Right("00000" & Format(curPos4), 6) & "," & RichTextBox1.SelText, 3
End Sub

Private Sub RichTextBox1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 2 Then
  PopupMenu Edit '调出右键菜单
Else
  If RichTextBox1.SelLength Then curPos4 = RichTextBox1.SelStart '用鼠标选定一段文本时的光标位置
End If
End Sub

我来回复

您尚未登录,请登录后再回复。点此登录或注册