散分了：使用RichTextBox控件提供用户编辑功能，加入类似word的“撤销”和“恢复”功能，来者有分

[goj2000]

给您的文字编辑程序添加一剂“后悔药”

程序实现功能：使用RichTextBox控件提供用户编辑功能，加入类似word的“撤销”和“恢复”功能。

'***********************************************************************
'本程序是在拜读了《电脑报》2005.4.4天津张志鑫发表的文章的基础上改进而成的,
'您在应用下面这些代码时，请务必保留两行“*”之间的内容不要修改,
'主要改进有两点：
'1.增加一个控制可恢复次数的变量，以限制对内存的无限制使用，以免造成内存溢出
'2.修正一个原代码错误，避免用户进行恢复时出错的问题
'对报纸上原程序存在错误的测试可以通过连续输入0123456789试验,
'会发现撤销输入时是正确的，但恢复时就会出错,
'虚线之间的内容是我新加的，加入这些代码后，本程序将更加完美,
'在此对张志鑫先生一并表示感谢,
'修改之后的源程序可用以下连接下载：http://qdgoj.nease.net/vbundo.rar
' 或：http://www.68ceo.com/software/vbundo.rar
'　　青岛　许家国　　2005.4.7
'***********************************************************************

运行VB6，新建一标准.exe工程，点“工程/部件”菜单，选中“Microsoft Rich Textbox Control

6.0”前的“√”，在工具箱中就出出现“RichTextBox”控件，在窗体中建立一“RichTextBox”控件，命名为“rtbText”，再建立两个按钮

，分别命名为“cmdUndo”和“cmdRedo”，把下列代码依次输入即可。

本程序在VB6+WIN2000 Server环境下运行通过。

Option Explicit

Dim rtbUndoStack() As String '撤销堆栈
Dim rtbRedoStack() As String '恢复堆栈
Dim bChg As Boolean '记录富文本框内容是否发生变化

'----------------------------------------------------
'对原程序修改，增加一个控制可恢复次数的变量，以限制对内存的无限制使用，以免造成内存溢出
Dim UndoNum As Long
'----------------------------------------------------

Private Sub cmdUndo_Click()
If UBound(rtbUndoStack) > 1 Then
bChg = True
ReDim Preserve rtbRedoStack(UBound(rtbRedoStack) + 1) As String
rtbRedoStack(UBound(rtbRedoStack)) = RTBText.TextRTF
RTBText.TextRTF = rtbUndoStack(UBound(rtbUndoStack) - 1)
ReDim Preserve rtbUndoStack(UBound(rtbUndoStack) - 1) As String
End If

'----------------------------------------------------
'增加对Undo次数的判断与限制功能
If UBound(rtbRedoStack) > UndoNum Then
cmdUndo.Enabled = False
MsgBox ("只允许撤销 " & UndoNum & " 次")
End If
'----------------------------------------------------
End Sub

Private Sub Form_Load()
ReDim Preserve rtbUndoStack(1) As String
ReDim Preserve rtbRedoStack(1) As String
rtbUndoStack(1) = RTBText.TextRTF '初始化撤销堆栈元素
rtbRedoStack(1) = RTBText.TextRTF '初始化恢复堆栈元素
bChg = False

'----------------------------------------------------
'增加部分初始化代码
UndoNum = 3 '限定可恢复的次数为3
cmdRedo.Enabled = False
cmdUndo.Enabled = False
'----------------------------------------------------
End Sub

Private Sub RTBText_Change()
Dim N As Long
Dim M As Long

If bChg = False Then '判断富文本框内容是否首次被修改
ReDim Preserve rtbUndoStack(UBound(rtbUndoStack) + 1) As String
M = UBound(rtbUndoStack)
rtbUndoStack(M) = RTBText.TextRTF
ReDim Preserve rtbRedoStack(1) As String '清除恢复堆栈内容

'----------------------------------------------------
'报纸上的原程序的两个缺陷之一：如果没有限制，将可能造成内存溢出
If M > UndoNum + 1 Then '限制可恢复的次数
For N = 1 To M
rtbUndoStack(N - 1) = rtbUndoStack(N)
Next N
ReDim Preserve rtbUndoStack(M - 1) As String
End If
'----------------------------------------------------
Else
bChg = False
End If

'判断并设置恢复按钮是否可用
If UBound(rtbUndoStack) > 1 Then
cmdUndo.Enabled = True
Else
cmdUndo.Enabled = False
End If
If UBound(rtbRedoStack) > 1 Then
cmdRedo.Enabled = True
Else
cmdRedo.Enabled = False
End If
End Sub

Private Sub cmdRedo_Click()
If UBound(rtbRedoStack) > 1 Then
bChg = True
ReDim Preserve rtbUndoStack(UBound(rtbUndoStack) + 1) As String
'rtbUndoStack(UBound(rtbUndoStack)) = RTBText.TextRTF '报纸上程序的原位置，删除后放到下面的位置
RTBText.TextRTF = rtbRedoStack(UBound(rtbRedoStack))
ReDim Preserve rtbRedoStack(UBound(rtbRedoStack) - 1) As String

'报纸上的原程序两个缺陷之二：如果放在原位置，将造成恢复失败
rtbUndoStack(UBound(rtbUndoStack)) = RTBText.TextRTF
End If

'----------------------------------------------------
'增加对Redo次数的判断与限制功能
If UBound(rtbRedoStack) <= 1 Then
cmdRedo.Enabled = False
End If
'----------------------------------------------------
End Sub

[daisy8675]

复原：

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
Const EM_UNDO = &HC7

Private Sub mnuundo_Click()
Dim UndoResult As Long
UndoResult = SendMessage(RichTextBox1.hwnd, EM_UNDO, 0, 0)
'传回值 UndoResult = -1 表示 Undo 不成功
End Sub
剪下

Private Sub mnucut_Click()
'清空剪贴簿内容
Clipboard.Clear
'将标示的文字复制到剪贴簿
Clipboard.SetText RichTextBox1.SelText
'清除标示的文字
RichTextBox1.SelText = ""
End Sub
复制

Private Sub mnucopy_Click()
'清空剪贴簿内容
Clipboard.Clear
'将标示的文字复制到剪贴簿
Clipboard.SetText RichTextBox1.SelText
End Sub
贴上

Private Sub mnupaste_Click()
'若有标示的区域，则将剪贴簿中的内容复制到光标所标示的区域
'若没有标示的区域，则将剪贴簿中的内容插入游标所在的地方
RichTextBox1.SelText = Clipboard.GetText
End Sub
删除

Private Sub mnudelete_Click()
'清除标示的文字
RichTextBox1.SelText = ""
End Sub
全选

Private Sub mnuselall_Click()
'将文字框中所有文字标示起来
RichTextBox1.SelStart = 0
RichTextBox1.SelLength = Len(RichTextBox1.Text)
End Sub

[daisy8675]

他的优点是加入了可恢复的次数而已。木什么难点，不是很容易懂吗

[daisy8675]

看错，不好意思，以为你在问，走了，Sorry

[wzzwwz]

顶

[intocsdn]

我来拿分

[cindytsai]

帮顶一下

[shiyunlong]

up

[XenosPeng]

up
mark