The RichTextBox actually supports multiple undo and redo. However, this functionality is hidden from VB programmers. In order to be able to use the undo and redo facilities, you need to add the following code.
Add this code to the Form_Load() event of the form that contains the RichTextBox control. We are calling the RichTextBox rtfText
Dim lStyle As Long
'// required to 'reveal' multiple undo
'// set rich text box style
lStyle = TM_RICHTEXT Or TM_MULTILEVELUNDO Or TM_MULTICODEPAGE
SendMessageLong rtfText.hwnd, EM_SETTEXTMODE, lStyle, 0
Then, add the code below. This code also adds cut/copy/paste/clear functionality, and expects the following menu items:
Menu Name | Caption |
mnuEdit | &Edit |
mnuEditUndo | &Undo |
mnuEditRedo | &Redo |
mnuEditCut | Cu&t |
mnuEditCopy | &Copy |
mnuEditPaste | &Paste |
mnuEditClear | C&lear |
Call the UpdateItems procedure in the mnuEdit_Click() event. This procedure updates the menu items.
Public Property Get UndoType() As ERECUndoTypeConstants
UndoType = SendMessageLong(rtfText.hWnd, EM_GETUNDONAME,
0, 0)
End Property
Public Property Get RedoType() As ERECUndoTypeConstants
RedoType = SendMessageLong(rtfText.hWnd, EM_GETREDONAME,
0, 0)
End Property
Public Property Get CanPaste() As Boolean
CanPaste = SendMessageLong(rtfText.hWnd, EM_CANPASTE, 0, 0)
End Property
Public Property Get CanCopy() As Boolean
If rtfText.SelLength > 0 Then
CanCopy = True
End If
End Property
Public Property Get CanUndo() As Boolean
CanUndo = SendMessageLong(rtfText.hWnd, EM_CANUNDO, 0, 0)
End Property
Public Property Get CanRedo() As Boolean
CanRedo = SendMessageLong(rtfText.hWnd, EM_CANREDO, 0, 0)
End Property
'///////////////////////////////////////////////////////
'// Methods
Public Sub Undo()
SendMessageLong rtfText.hWnd, EM_UNDO, 0, 0
End Sub
Public Sub Redo()
SendMessageLong rtfText.hWnd, EM_REDO, 0, 0
End Sub
Public Sub Cut()
SendMessageLong rtfText.hWnd, WM_CUT, 0, 0
End Sub
Public Sub Copy()
SendMessageLong rtfText.hWnd, WM_COPY, 0, 0
End Sub
Public Sub Paste()
SendMessageLong rtfText.hWnd, WM_PASTE, 0, 0
End Sub
Public Sub Clear()
rtfText.SelText = Empty
End Sub
Public Sub UpdateItems()
Dim bCanUndo As Boolean
'// Undo/Redo options:
bCanUndo = CanUndo
mnuEditUndo.Enabled = bCanUndo
'// Set Undo Text
If (bCanUndo) Then
mnuEditUndo.Caption = "&Undo
" & TranslateUndoType(UndoType)
Else
mnuEditUndo.Caption = "&Undo"
End If
'// Set Redo Text
bCanUndo = CanRedo
If (bCanUndo) Then
mnuEditRedo.Caption = "&Redo
" & TranslateUndoType(RedoType)
Else
mnuEditRedo.Caption = "&Redo"
End If
mnuEditRedo.Enabled = bCanUndo
tbToolBar.Buttons("Redo").Enabled = bCanUndo
'// Cut/Copy/Paste/Clear options
mnuEditCut.Enabled = CanCopy
mnuEditCopy.Enabled = CanCopy
mnuEditPaste.Enabled = CanPaste
mnuEditClear.Enabled = CanCopy
End Sub
'// Returns the undo/redo type
Private Function TranslateUndoType(ByVal eType As ERECUndoTypeConstants) As
String
Select Case eType
Case ercUID_UNKNOWN
TranslateUndoType = "Last Action"
Case ercUID_TYPING
TranslateUndoType = "Typing"
Case ercUID_PASTE
TranslateUndoType = "Paste"
Case ercUID_DRAGDROP
TranslateUndoType = "Drag Drop"
Case ercUID_DELETE
TranslateUndoType = "Delete"
Case ercUID_CUT
TranslateUndoType = "Cut"
End Select
End Function
Then, add this code to a module
'// View Types
Public Enum ERECViewModes
ercDefault = 0
ercWordWrap = 1
ercWYSIWYG = 2
End Enum
'// Undo Types
Public Enum ERECUndoTypeConstants
ercUID_UNKNOWN = 0
ercUID_TYPING = 1
ercUID_DELETE = 2
ercUID_DRAGDROP = 3
ercUID_CUT = 4
ercUID_PASTE = 5
End Enum
'// Text Modes
Public Enum TextMode
TM_PLAINTEXT = 1
TM_RICHTEXT = 2 ' /* default behavior */
TM_SINGLELEVELUNDO = 4
TM_MULTILEVELUNDO = 8 ' /* default behavior */
TM_SINGLECODEPAGE = 16
TM_MULTICODEPAGE = 32 ' /* default behavior */
End Enum
Public Const WM_COPY = &H301
Public Const WM_CUT = &H300
Public Const WM_PASTE = &H302
Public Const WM_USER = &H400
Public Const EM_SETTEXTMODE = (WM_USER + 89)
Public Const EM_UNDO = &HC7
Public Const EM_REDO = (WM_USER + 84)
Public Const EM_CANPASTE = (WM_USER + 50)
Public Const EM_CANUNDO = &HC6&
Public Const EM_CANREDO = (WM_USER + 85)
Public Const EM_GETUNDONAME = (WM_USER + 86)
Public Const EM_GETREDONAME = (WM_USER + 87)
Public Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any)
As Long
And that's it! What you thought is impossible, is actually possible in a few lines of code. Of course, it would have been much easier if Microsoft had provided these functions for VB programmers anyway. This code has been adapted from VB Accelerator's RichEdit control.
Comments