以下内容为收藏而来想要无限地undo下次,就不那么简单了。土人曾拟编写一个,却无意中发现了Bart Lorang,一个年仅十多岁的美国小子已经在网上公开了类似的代码。这家伙敢跟老盖叫劲儿,号称"Not the next Bill Gates, but the first Bart Lorang",好大的口气!不过他的程序确实不错,现特意将其内容拿出来给大家瞧瞧。为了适用于中文环境,土人对源码作了些微改动。注意:不仅可以undo,还可以redo哟! (如果你用此代码于你编制的记事本,Bart Lorang要求给他发一个拷贝:[email protected])' ****** 模块代码:'申明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 SubPrivate Sub Command1_Click() Undo End SubPrivate Sub Form_Load() RichTextBox1.Text = "" Command1.Caption = "撤销" Command2.Caption = "恢复" trapUndo = True RichTextBox1_Change RichTextBox1_SelChange Show DoEvents End SubPrivate Sub mnuCopy_Click() Clipboard.SetText RichTextBox1.SelText, 1 '拷贝 End SubPrivate Sub mnuCut_Click() Clipboard.SetText RichTextBox1.SelText, 1 '剪切 RichTextBox1.SelText = "" End SubPrivate Sub mnuDelete_Click() RichTextBox1.SelText = "" '删除 End SubPrivate Sub mnuPaste_Click() RichTextBox1.SelText = "" '这一步对Undo功能至关重要 RichTextBox1.SelText = Clipboard.GetText(1) '粘贴 End SubPrivate Sub mnuRedo_Click() Command2_Click End SubPrivate Sub mnuSelectAll_Click() '全选 RichTextBox1.SelStart = 0 RichTextBox1.SelLength = Len(RichTextBox1.Text) End SubPrivate Sub mnuUndo_Click() Command1_Click End SubPrivate Sub RichTextBox1_Change() If Not trapUndo Then Exit Sub '因为because trapping is disabledDim 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 SubPrivate Sub RichTextBox1_KeyDown(KeyCode As Integer, Shift As Integer) If Shift = 2 Then KeyCode = 0 End If End SubPrivate Sub RichTextBox1_KeyUp(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeySpace Then RichTextBox1.SelFontName = "宋体" '定义字体 End If End SubPrivate 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
(如果你用此代码于你编制的记事本,Bart Lorang要求给他发一个拷贝:[email protected])' ****** 模块代码:'申明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 SubPrivate Sub Command1_Click()
Undo
End SubPrivate Sub Form_Load()
RichTextBox1.Text = ""
Command1.Caption = "撤销"
Command2.Caption = "恢复"
trapUndo = True
RichTextBox1_Change
RichTextBox1_SelChange
Show
DoEvents
End SubPrivate Sub mnuCopy_Click()
Clipboard.SetText RichTextBox1.SelText, 1 '拷贝
End SubPrivate Sub mnuCut_Click()
Clipboard.SetText RichTextBox1.SelText, 1 '剪切
RichTextBox1.SelText = ""
End SubPrivate Sub mnuDelete_Click()
RichTextBox1.SelText = "" '删除
End SubPrivate Sub mnuPaste_Click()
RichTextBox1.SelText = "" '这一步对Undo功能至关重要
RichTextBox1.SelText = Clipboard.GetText(1) '粘贴
End SubPrivate Sub mnuRedo_Click()
Command2_Click
End SubPrivate Sub mnuSelectAll_Click()
'全选
RichTextBox1.SelStart = 0
RichTextBox1.SelLength = Len(RichTextBox1.Text)
End SubPrivate Sub mnuUndo_Click()
Command1_Click
End SubPrivate Sub RichTextBox1_Change()
If Not trapUndo Then Exit Sub '因为because trapping is disabledDim 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 SubPrivate Sub RichTextBox1_KeyDown(KeyCode As Integer, Shift As Integer)
If Shift = 2 Then
KeyCode = 0
End If
End SubPrivate Sub RichTextBox1_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeySpace Then
RichTextBox1.SelFontName = "宋体" '定义字体
End If
End SubPrivate 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