English
资源说明：-----------------------
'False_VB教程：VB制作带撤销功能的记事本
QQ:5333784
'应网友要求，今天给大家带来一个用VB做带有撤销功能的记事本
'VB写记事本网上已经有很多教程了
'但是却很少有撤销功能的
'今天我就给大家做一个
'我们开始吧
'编辑菜单
'好了，
'下面我们添加一个模块
'代码我已经测试好了
'也会给大家打包的
'下面来写入代码
'好了，这些是记事本最基本的应用
'希望大家可以写出一个属于自己的更多功能的记事本
'今天的教程就到这里了
'我们下次见
'以下是代码：
'----------------------------------华丽的分割线-------------------------------------------------
Dim sFind As String'生命查找变量
Dim FileType, FiType As String
'----------------------------------华丽的分割线-------------------------------------------------
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
'----------------------------------华丽的分割线-------------------------------------------------
Private Sub Form_Load()'窗体加载时
Dim lStyle As Long
lStyle = TM_RICHTEXT Or TM_MULTILEVELUNDO Or TM_MULTICODEPAGE
SendMessageLong rtfText.hwnd, EM_SETTEXTMODE, lStyle, 0
End Sub
'----------------------------------华丽的分割线-------------------------------------------------
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
'----------------------------------华丽的分割线-------------------------------------------------
'----------------------------------多了个华丽的分割线-------------------------------------------
'新建文件
rtfText.Text = "" '清空文本框
FileName = "未命名"
Me.Caption = FileName
'----------------------------------华丽的分割线-------------------------------------------------
'打开文件
CommonDialog1.Filter = "文本文档(*.txt)|*.txt|RTF文档(*.rtf)|*.rtf|所有文件(*.*)|*.*"
CommonDialog1.ShowOpen
rtfText.Text = "" '清空文本框
FileName = CommonDialog1.FileName
rtfText.LoadFile FileName
Me.Caption = "个人专用记事本：" & FileName
'----------------------------------华丽的分割线-------------------------------------------------
'保存文件
Open App.Path & "\False_VB教程.txt" For Append As #1
Print #1, rtfText.Text
Close #1
'----------------------------------华丽的分割线-------------------------------------------------
'另保存文件
CommonDialog1.Filter = "文本文档(*.txt)|*.txt|RTF文档(*.rtf)|*.rtf|所有文件(*.*)|*.*"
CommonDialog1.ShowSave
FileType = CommonDialog1.FileTitle
FiType = LCase(Right(FileType, 3))
FileName = CommonDialog1.FileName
Select Case FiType
Case "txt"
rtfText.SaveFile FileName, rtfText
Case "rtf"
rtfText.SaveFile FileName, rtfRTF
Case "*.*"
rtfText.SaveFile FileName
End Select
Me.Caption = "个人专用记事本：" & FileName
'----------------------------------华丽的分割线-------------------------------------------------
'撤销
SendMessageLong rtfText.hwnd, EM_UNDO, 0, 0
End Sub
'----------------------------------华丽的分割线-------------------------------------------------
'重做
SendMessageLong rtfText.hwnd, EM_REDO, 0, 0
'----------------------------------华丽的分割线-------------------------------------------------
'复制
SendMessageLong rtfText.hwnd, WM_COPY, 0, 0
'----------------------------------华丽的分割线-------------------------------------------------
'粘贴
SendMessageLong rtfText.hwnd, WM_PASTE, 0, 0
'----------------------------------华丽的分割线-------------------------------------------------
'清除
rtfText.SelText = Empty
'----------------------------------华丽的分割线-------------------------------------------------
'剪切
SendMessageLong rtfText.hwnd, WM_CUT, 0, 0
'----------------------------------华丽的分割线-------------------------------------------------
'全选
rtfText.SelStart = 0
rtfText.SelLength = Len(rtfText.Text)
'----------------------------------华丽的分割线-------------------------------------------------
'时间日期
rtfText.Text = rtfText.Text & " " & Now
'----------------------------------华丽的分割线-------------------------------------------------
'查找
sFind = InputBox("请输入要查找的字、词：", "查找内容", sFind)
rtfText.Find sFind
'----------------------------------华丽的分割线-------------------------------------------------
'继续查找
rtfText.SelStart = rtfText.SelStart + rtfText.SelLength + 1
rtfText.Find sFind, , Len(rtfText)
'----------------------------------华丽的分割线-------------------------------------------------
'关于
MsgBox "作者QQ：1302938783 QQ群：26891547 E-mail:falsevb@163.com 欢迎喜欢VB的朋友加入我的QQ群，大家一起讨论，请那些所谓的什么什么黑客要盗什么什么QQ的人自重，这个群只是喜欢VB的朋友一起交流和讨论，了解吗？", 64, "关于"
'----------------------------------华丽的分割线-------------------------------------------------
'防止在切换输入法时字体自变
Private Sub rtfText_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeySpace Then
rtfText.SelFontName = CommonDialog1.FontName
End If
End Sub
'----------------------------------华丽的分割线-------------------------------------------------
'模块
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
'----------------------------------结束华丽的分割线--------------------------------------------
本源码包内暂不包含可直接显示的源代码文件，请下载源码包。
