‘模塊中
Public UndoStack As New Collection
Public RedoStack As New Collection
'設置窗口置頂
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
'初始化：SetWindowPos，設置窗體總在最前面所需要的常量
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_NOCOPYBITS = &H80
Private Const SWP_NOOWNERZORDER = &H200
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Private Const HWND_TOP = 0
Private Const HWND_BOTTOM = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
'設定窗體位居最前面的過程
Public Sub SetOnTop(frm As Object, bSetting As Boolean)
If bSetting Then
'將窗體設置成總在最前
SetWindowPos Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Else
'取消窗體總在最前設置
SetWindowPos Form1.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End If
End Sub
'窗口中
Option Explicit
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
Private Const EM_CANUNDO = &HC6
Private Const EM_UNDO = &HC7
Dim rtbUndoStack() As String '撤銷堆棧
Dim rtbRedoStack() As String '恢復堆棧
Dim bChg As Boolean '記錄富文本框內容是否發生變化
Dim warning As Long
Private Sub Form_Load()
UndoStack.Add MainTxtBox.Text
End Sub
Private Sub mmuAbout_Click()
MsgBox "Copyright by 南瓜頭QQ:690936288"
End Sub
Private Sub mmuCopy_Click()
Clipboard.Clear
Clipboard.SetText MainTxtBox.SelText
End Sub
Private Sub mmuCut_Click()
Clipboard.Clear
Clipboard.SetText MainTxtBox.SelText
MainTxtBox.SelText = ""
End Sub
Private Sub mmuDel_Click()
MainTxtBox.SelText = ""
End Sub
Private Sub mmuExit_Click()
Unload Me
End Sub
Private Sub mmuFont_Click()
On Error Resume Next
comDlg.Flags = &H3 Or &H1 Or &H2 Or &H100
comDlg.Action = 4
MainTxtBox.Font.Name = comDlg.FontName
MainTxtBox.Font.Size = comDlg.FontSize
MainTxtBox.Font.Bold = comDlg.FontBold
MainTxtBox.Font.Italic = comDlg.FontItalic
MainTxtBox.Font.Underline = comDlg.FontUnderline
MainTxtBox.SelColor = comDlg.Color
End Sub
Private Sub mmuNew_Click()
warning = MsgBox("當前的文檔將會丟失，您確認要新建文檔嗎？", vbOKCancel, "Warning!")
'warning
If warning = vbCancel Then
Else
If warning = vbOK Then
MainTxtBox.Text = ""
End If
End If
End Sub
Private Sub mmuOpen_Click()
On Error GoTo non
warning = MsgBox("當前的文檔將會丟失，您確認要打開新的文檔嗎？", vbOKCancel, "Warning!")
'warning
If warning = vbCancel Then
Else
If warning = vbOK Then
comDlg.Filter = "Text files|*.txt|WORD Files (*.doc)|*.doc|HTML Files (*.html)|*.html|All Files (*.*)|*.*"
comDlg.ShowOpen
MainTxtBox.LoadFile comDlg.FileName, rtfText
End If
End If
non:
End Sub
Private Sub mmuPaste_Click()
MainTxtBox.SelText = Clipboard.GetText(1)
End Sub
Private Sub mmuRedo_Click()
If RedoStack.Count > 0 Then
UndoStack.Add RedoStack(RedoStack.Count)
RedoStack.Remove RedoStack.Count
MainTxtBox.Text = UndoStack(UndoStack.Count)
End If
End Sub
Private Sub mmuSave_Click()
On Error Resume Next
comDlg.FileName = ""
comDlg.ShowSave
If comDlg.FileName = "" Then Exit Sub
Open comDlg.FileName For Output As #1
Print #1, MainTxtBox.Text
Close #1
MsgBox "保存完畢！", vbOKOnly, "保存文檔"
End Sub
Private Sub mmuSelectAll_Click()
MainTxtBox.SelStart = 0
MainTxtBox.SelLength = Len(MainTxtBox.Text)
End Sub
Private Sub mmuStatusBar_Click()
If mmuStatusBar.Checked Then
StatusBar1.Visible = False
mmuStatusBar.Checked = False
Else
StatusBar1.Visible = True
mmuStatusBar.Checked = True
End If
End Sub
Private Sub mmuUndo_Click()
'撤銷
If UndoStack.Count <= 1 Then Exit Sub
RedoStack.Add UndoStack(UndoStack.Count)
UndoStack.Remove UndoStack.Count
MainTxtBox.Text = UndoStack(UndoStack.Count)
End Sub
'設置彈出式菜單（即在編輯框中單擊鼠標右鍵時彈出的動態菜單）
Private Sub MainTxtBox_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 2 Then
PopupMenu mmuEdit, vbPopupMenuLeftAlign
Else
Exit Sub
End If
End Sub
Private Sub MainTxtBox_Change()
If UndoStack(UndoStack.Count) <> MainTxtBox.Text Then
UndoStack.Add MainTxtBox.Text
If UndoStack.Count > 100 Then
UndoStack.Remove 1
End If
If RedoStack.Count > 0 Then
Set RedoStack = New Collection
'Debug.Print "清空Redo堆棧 " & Time
End If
End If
End Sub
Private Sub mmuWindowOnTop_Click()
If mmuWindowOnTop.Checked Then
SetOnTop Form1, False
mmuWindowOnTop.Checked = False
Else
SetOnTop Form1, True
mmuWindowOnTop.Checked = True
End If
End Sub