SendMessage函数在RichTextBox中实现：
一、一次撤销功能
二、无限地撤销功能
生活中的What's done cannot be undone在我们的程序中应该改为What's done can always be undone。你不相信？那么请看——
如果仅仅象MS的小记事本那样只有一次undo功能，那不是一件麻烦事，用SendMessage函数就可以轻松实现。下列代码能使RichTextBox有一次撤销操作的功能：
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 WM_UNDO = &H304
'下一行为按钮或菜单代码
SendMessage RichTextBox1.hwnd, WM_UNDO, 0, 0
是不是很容易？不过，想要无限地undo下次，就不那么简单了。土人曾拟编写一个，却无意中发现了Bart Lorang,一个年仅十多岁的美国小子已经在网上公开了类似的代码。这家伙敢跟老盖叫劲儿，号称"Not the next Bill Gates, but the first Bart Lorang"，好大的口气！不过他的程序确实不错，现特意将其内容拿出来给大家瞧瞧。为了适用于中文环境，土人对源码作了些微改动。注意：不仅可以undo，还可以redo哟！
(如果你用此代码于你编制的记事本，Bart Lorang要求给他发一个拷贝：BartLorang@POBoxes.com)
' ****** 模块代码：
'申明API函数
Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Long) As Long
'常数
Public Const WM_USER = &H400
Public Const EM_HIDESELECTION = WM_USER + 63
' ****** 类模块代码：
Public SelStart As Long '文本框中的开始位置
Public TextLen As Long '文本长度
Public Text As String '文本内容
' ****** 窗体代码：
'请给窗体添加按钮两个、RichTextBox一个，取默认值；
'菜单若干：——
'层次 Name属性 Caption属性
' 1 Edit 编辑
' 2 mnuUndo 撤销
' 2 mnuRedo 恢复
' 2 mnuCut 剪切
' 2 mnuCopy 复制
' 2 mnuPaste 粘贴
' 2 mnuDelete 删除
' 2 mnuSelectAll 全选
Private trapUndo As Boolean
Private UndoStack As New Collection '可撤销的集合
Private RedoStack As New Collection '可恢复的集合
Private Sub Command2_Click()
Redo
End Sub
Private Sub Command1_Click()
Undo
End Sub
Private Sub Form_Load()
RichTextBox1.Text = ""
Command1.Caption = "撤销"
Command2.Caption = "恢复"
trapUndo = True
RichTextBox1_Change
RichTextBox1_SelChange
Show
DoEvents
End Sub
Private Sub mnuCopy_Click()
Clipboard.SetText RichTextBox1.SelText, 1 '拷贝
End Sub
Private Sub mnuCut_Click()
Clipboard.SetText RichTextBox1.SelText, 1 '剪切
RichTextBox1.SelText = ""
End Sub
Private Sub mnuDelete_Click()
RichTextBox1.SelText = "" '删除
End Sub
Private Sub mnuPaste_Click()
RichTextBox1.SelText = "" '这一步对Undo功能至关重要
RichTextBox1.SelText = Clipboard.GetText(1) '粘贴
End Sub
Private Sub mnuRedo_Click()
Command2_Click
End Sub
Private Sub mnuSelectAll_Click()
'全选
RichTextBox1.SelStart = 0
RichTextBox1.SelLength = Len(RichTextBox1.Text)
End Sub
Private Sub mnuUndo_Click()
Command1_Click
End Sub
Private Sub RichTextBox1_Change()
If Not trapUndo Then Exit Sub '因为because trapping is disabled
Dim newElement As New UndoElement '创建新的undo集合
Dim c%, l&
'移除所有的Redo项目
For c% = 1 To RedoStack.Count
RedoStack.Remove 1
Next c%
'给新集合赋值
newElement.SelStart = RichTextBox1.SelStart
newElement.TextLen = Len(RichTextBox1.Text)
newElement.Text = RichTextBox1.Text
'将其加入 undo 堆栈
UndoStack.Add Item:=newElement
'设置窗体控件的属性
EnableControls
End Sub
Private Sub RichTextBox1_KeyDown(KeyCode As Integer, Shift As Integer)
If Shift = 2 Then
KeyCode = 0
End If
End Sub
Private Sub RichTextBox1_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeySpace Then
RichTextBox1.SelFontName = "宋体" '定义字体
End If
End Sub
Private Sub RichTextBox1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then '显示
PopupMenu mnuEdit
End If
End Sub
'菜单属性设置
Private Sub RichTextBox1_SelChange()
Dim ln&
If Not trapUndo Then Exit Sub
ln& = RichTextBox1.SelLength
mnuCut.Enabled = ln& '不选择文本则禁用
mnuCopy.Enabled = ln& '同上
mnuPaste.Enabled = Len(Clipboard.GetText(1)) '剪贴版为空则禁用
mnuDelete.Enabled = ln& '不选择文本则禁用
mnuSelectAll.Enabled = CBool(Len(RichTextBox1.Text)) '文本框无内容则禁用
End Sub
'设置按钮、菜单属性
Private Sub EnableControls()
Command1.Enabled = UndoStack.Count > 1
Command2.Enabled = RedoStack.Count > 0
mnuUndo.Enabled = Command1.Enabled
mnuRedo.Enabled = Command2.Enabled
RichTextBox1_SelChange
End Sub
'Change子程序
Public Function Change(ByVal lParam1 As String, ByVal lParam2 As String, startSearch As Long) As String
Dim tempParam$
Dim d&
If Len(lParam1) > Len(lParam2) Then '交换
tempParam$ = lParam1
lParam1 = lParam2
lParam2 = tempParam$
End If
d& = Len(lParam2) - Len(lParam1)
Change = Mid(lParam2, startSearch - d&, d&)
End Function
'Undo子程序
Public Sub Undo()
Dim chg$, X&
Dim DeleteFlag As Boolean '标志删除或添加变量
Dim objElement As Object, objElement2 As Object
If UndoStack.Count > 1 And trapUndo Then
trapUndo = False
DeleteFlag = UndoStack(UndoStack.Count - 1).TextLen < UndoStack(UndoStack.Count).TextLen
If DeleteFlag Then '删除
'cmdDummy.SetFocus '改变焦点
X& = SendMessage(RichTextBox1.hWnd, EM_HIDESELECTION, 1&, 1&)
Set objElement = UndoStack(UndoStack.Count)
Set objElement2 = UndoStack(UndoStack.Count - 1)
RichTextBox1.SelStart = objElement.SelStart - (objElement.TextLen - objElement2.TextLen)
RichTextBox1.SelLength = objElement.TextLen - objElement2.TextLen
RichTextBox1.SelText = ""
X& = SendMessage(RichTextBox1.hWnd, EM_HIDESELECTION, 0&, 0&)
Else '添加
Set objElement = UndoStack(UndoStack.Count - 1)
Set objElement2 = UndoStack(UndoStack.Count)
chg$ = Change(objElement.Text, objElement2.Text, _
objElement2.SelStart + 1 + Abs(Len(objElement.Text) - Len(objElement2.Text)))
RichTextBox1.SelStart = objElement2.SelStart
RichTextBox1.SelLength = 0
RichTextBox1.SelText = chg$
RichTextBox1.SelStart = objElement2.SelStart
If Len(chg$) > 1 And chg$ <> vbCrLf Then
RichTextBox1.SelLength = Len(chg$)
Else
RichTextBox1.SelStart = RichTextBox1.SelStart + Len(chg$)
End If
End If
RedoStack.Add Item:=UndoStack(UndoStack.Count)
UndoStack.Remove UndoStack.Count
End If
EnableControls
trapUndo = True
RichTextBox1.SetFocus
End Sub
'Redo子程序
Public Sub Redo()
Dim chg$
Dim DeleteFlag As Boolean '标志删除或添加文本的变量
Dim objElement As Object
If RedoStack.Count > 0 And trapUndo Then
trapUndo = False
DeleteFlag = RedoStack(RedoStack.Count).TextLen < Len(RichTextBox1.Text)
If DeleteFlag Then '为真则删除
Set objElement = RedoStack(RedoStack.Count)
RichTextBox1.SelStart = objElement.SelStart
RichTextBox1.SelLength = Len(RichTextBox1.Text) - objElement.TextLen
RichTextBox1.SelText = ""
Else '反之则添加
Set objElement = RedoStack(RedoStack.Count)
chg$ = Change(RichTextBox1.Text, objElement.Text, objElement.SelStart + 1)
RichTextBox1.SelStart = objElement.SelStart - Len(chg$)
RichTextBox1.SelLength = 0
RichTextBox1.SelText = chg$
RichTextBox1.SelStart = objElement.SelStart - Len(chg$)
If Len(chg$) > 1 And chg$ <> vbCrLf Then
RichTextBox1.SelLength = Len(chg$)
Else
RichTextBox1.SelStart = RichTextBox1.SelStart + Len(chg$)
End If
End If
UndoStack.Add Item:=objElement
RedoStack.Remove RedoStack.Count
End If
EnableControls
trapUndo = True
RichTextBox1.SetFocus
End Sub
|
