现在报名第二号人:richtextbox问题可以吗?
以前跟过这贴,不知道问题怎么解决的[email protected]谢谢!!
以前跟过这贴,不知道问题怎么解决的[email protected]谢谢!!
解决方案 »
- 获取VB程序里标签的内容
- vb中如何判断 当前打开了哪些windows窗口 并关闭之?比如 我当前打开了"C:\123"和"D:\456"两个windows窗口,怎么判断他们已经打开,并关闭他们?
- 急!在线等!MSFLexGrid控件中要选择其中第二列和所有行的内容怎么表示呢?主要是将其录入到数据库对应的一个字段中!谢谢!
- Richtextbox和Form的KeyPreview是否有冲突?
- 怎样得到菜单中的某个值???
- 我是一个菜鸟想做vb与access的连接,还不知道具体需要哪些操作。例如需要什么属性与什么语句。请各位指点。
- 新手求教
- VB程序员的前途~
- vb中将16进制转换成10进制的函数是什么?
- **************只要能解决问题,多少分您开口***************
- VB壓縮文件時,文件名有"[*]"的壓縮不了,這是什麼?
- 请教关于记录键盘输入的问题(〓高分相送!!!〓)
作者:土人
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 LongConst 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要求给他发一个拷贝:[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 VB编程乐园版权所有?,1999-2000
网页设计制作:木子
解决这问题N个关键,
一是什么环节可以记录变化和变化记录方案。
CHANGE事件如果能够满足记录变化的机会(需要测试),我认为再加上启动时钟(防止太小的记录区间)就可以了。
二是保存方案,不大的变化可以用变量或数组保存,留一个指针就行。作为技术总监,提点到此就可以了吧?