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

goj2000 2005-04-07 08:25:39
给您的文字编辑程序添加一剂“后悔药”

程序实现功能:使用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

...全文
153 8 打赏 收藏 举报
写回复
8 条回复
切换为时间正序
当前发帖距今超过3年,不再开放新的回复
发表回复
XenosPeng 2005-04-15
up
mark
  • 打赏
  • 举报
回复
shiyunlong 2005-04-15
up
  • 打赏
  • 举报
回复
cindytsai 2005-04-07
帮顶一下
  • 打赏
  • 举报
回复
intocsdn 2005-04-07
我来拿分
  • 打赏
  • 举报
回复
wzzwwz 2005-04-07
  • 打赏
  • 举报
回复
daisy8675 2005-04-07
看错,不好意思,以为你在问,走了,Sorry
  • 打赏
  • 举报
回复
daisy8675 2005-04-07
他的优点是加入了可恢复的次数而已。木什么难点,不是很容易懂吗
  • 打赏
  • 举报
回复
daisy8675 2005-04-07
复原:

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
  • 打赏
  • 举报
回复
相关推荐
发帖
控件

1434

社区成员

VB 控件
社区管理员
  • 控件
加入社区
帖子事件
创建了帖子
2005-04-07 08:25
社区公告
暂无公告