胡子高级记事本VB版1.093源码

'胡子高级记事本VB版1.093源码
'━━━━━━━━━━━━━━━━━━━━━━━━━━

form1

Private 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
'总在最上面的API
Dim ontop As Boolean
Dim cliptext As String    '上一剪粘板文本
Dim mydocments As String  '取我的文档目录
Dim LWidth As Integer    '自动换行的行宽
Dim CurFileName As String    '前一个文本的文件名
'Dim tsys(9, 3) As String    '标题、文件名、文本、保存。(卡号即数组索引)  '改为在模块2中的public公有变量


Private Sub copy_Click()
    Call 复制_Click
End Sub

Private Sub cut_Click()
    Call 剪切_Click
End Sub

Private Sub del_Click()
    Call 删除_Click
End Sub

Private Sub Form_Load()
    On Error GoTo label
    SSTab.Move 0, 360, Form1.Width - 110, Form1.Height - 1525
    RichTextBox.Width = SSTab.Width - 20
    RichTextBox.Height = SSTab.Height - 395

    mydocments = Environ("userprofile") & "/My Documents"  '取我的文档目录

    '  LineWidth = RichTextBox.RightMargin  '设为自动换行
    '  RichTextBox.RightMargin = LineWidth
    '
    RichTextBox.OLEDropMode = 1
    Tsys(0, 0) = "新文件1"
    Tsys(0, 1) = ""
    Tsys(0, 2) = ""
    Tsys(0, 3) = "F"
    StatusBar1.Panels(2) = "文件名："         '在状态栏中显示文章数及全文件名
    StatusBar1.Panels(1) = "文章数：" & SSTab.Tabs

    Load Form2
    Form2.Visible = False
    Form2.Move Screen.Width - Form2.Width, Screen.Height - Form2.Height - 450
    'MsgBox App.Path
    Form1.RichTextBox.SetFocus
label:
    Exit Sub

End Sub

Private Sub Form_Resize()
    SSTab.Move 0, 360, Form1.Width - 110, Form1.Height - 1525
    RichTextBox.Width = SSTab.Width - 20
    RichTextBox.Height = SSTab.Height - 395
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unload Form2
    Unload Form3
    Unload Form4
End Sub

Private Sub paste_Click()
    Call 粘贴_Click
End Sub

Private Sub RichTextBox_DblClick()
    With RichTextBox
        If .Tag = "min" Then
            .Font.Size = 11
            .Font.Name = "微软雅黑"
            .Tag = "max"
            Exit Sub
        Else
            .Font.Size = 9
            .Font.Name = "宋体"
            .Tag = "min"
            Exit Sub
        End If
    End With
End Sub

Private Sub RichTextBox_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
'MouseDown事件各种语法包含下列部分：
'button 返回一个整数，用来标识该事件的产生是按下哪个按钮
'其中 左按钮（位 0），右按钮（位 2），以及中间按钮（位 4）
'shift   返回一个整数，标示是否同时有Shift,Ctrl,Alt键按下
'x, y    返回一个指定鼠标指针当前位置的数
'Button = 2 表示右键按下
'PopupMenu方法用来弹出一个菜单
'语法是 object.PopupMenu menuname, flags, X, Y
'mnufile是我们在菜单编辑器中设计好的菜单
'X,Y是弹出菜单的位置，可以为数字，如果直接写为X,Y则是在当前鼠标位置弹出菜单

    If Button = 2 Then
        PopupMenu 右键菜单, 0, x, y
    End If

End Sub

Private Sub RichTextBox_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Rem 拖放文件
    On Error GoTo label
    If RichTextBox.Text <> "" Then
        Call 新建_Click
    End If

    If Data.GetFormat(vbCFText) Then
        RichTextBox.LoadFile Data.GetData(vbCFText)
    End If

    If Data.Files.Count = 0 Then
        Exit Sub
    End If

    If Data.GetFormat(vbCFFiles) Then
        tt = LCase(Right(Data.Files(1), 3))
        ts = InStr("txt ini htm tml bas fmr bas cmd bat", tt)
        'MsgBox tt
        If ts = 0 Then
            Exit Sub
        Else
            RichTextBox.LoadFile Data.Files(1)  'Load one file for demo
        End If
    End If

    Caption = RichTextBox.FileName
    i = SSTab.Tab
    fnlen = Len(Caption)
    j = InStrRev(Caption, "/")
    shortfn = Mid(Caption, j + 1, fnlen - j - 4)
    shortfn = Left$(shortfn, 5)
    SSTab.Caption = shortfn

    Tsys(i, 1) = Caption
    StatusBar1.Panels(2) = "文件名：" & Tsys(i, 1)        '在状态栏中显示文章数及全文件名
    StatusBar1.Panels(1) = "文章数：" & 1 + SSTab.Tab & "/" & SSTab.Tabs

label:
    Exit Sub

End Sub

Private Sub RichTextBox_Validate(Cancel As Boolean)   'validate事件：当前控件将要失去焦点，即第二个控件获得焦点前
    Dim i
    i = SSTab.Tab
    Tsys(i, 2) = RichTextBox.Text     '当编辑框将要失去焦点时及时将临时文本存入数组
End Sub

Private Sub selt_Click()
    Call 全选_Click
End Sub

Private Sub SSTab_Click(PreviousTab As Integer)
    With SSTab
        i = .Tab
        RichTextBox.Text = ""
        RichTextBox.Text = Tsys(i, 2)
        StatusBar1.Panels(2) = "文件名：" & Tsys(i, 1)        '在状态栏中显示文章数及全文件名
        StatusBar1.Panels(1) = "文章数：" & 1 + SSTab.Tab & "/" & SSTab.Tabs
    End With
End Sub


Private Sub SSTab_DblClick()
    With SSTab
        If .Tab <> 0 Then
            i = SSTab.Tab
            SSTab.TabVisible(i) = False      '双击关闭当前文章
        End If
    End With
End Sub

Private Sub Timer1_Timer()
    If Clipboard.GetText <> "" And Clipboard.GetText <> cliptext Then
        Form2.List1.AddItem Clipboard.GetText, 0
        cliptext = Clipboard.GetText
    End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key

    Case "新建"
        Call 新建_Click
    Case "打开"
        Call 打开_Click
    Case "保存"
        Call 保存_Click
    Case "剪切"
        Call 剪切_Click
    Case "复制"
        Call 复制_Click
    Case "粘贴"
        Call 粘贴_Click
    Case "全选"
        Call 全选_Click
        Call 复制_Click
    Case "撤销"
        Call 撤销_Click
    Case "删除"
        If RichTextBox.SelText <> "" Then
            Call 删除_Click
        Else
            SendKeys "{DEL}"
        End If
    Case "行首缩进"
        Call 行首缩进_Click
    Case "删除行首空格"
        Call 删除行首空格_Click
    Case "插入空行"
        Call 段后插入空行_Click
    Case "删除空行"
        Call 删除空行_Click
    Case "分割线"
        RichTextBox.SelText = vbCrLf & "━━━━━━━━━━━━━━━━━━━━━━━━━━" & vbCrLf
    Case "方括号"
        If RichTextBox.SelText <> "" Then
            RichTextBox.SelText = "【" & RichTextBox.SelText & "】"
        Else
            RichTextBox.SelText = "【】"
            SendKeys "{LEFT}"
        End If
    Case "回车"
        SendKeys "{ENTER}"
    Case "硬回车"
        '测试
        MsgBox "未填写代码"
    Case "WORD"
        Call wordopen
    Case "最上面"
        总在最前面_Click
    Case "剪贴板"
        Form2.Visible = Not Form2.Visible  '取反
        Timer1.Interval = 300
    Case "计算器"
        Dim a() As String
        a() = Split(RichTextBox.Text, vbCrLf)
        For i = 0 To UBound(a)
            m = Val(a(i))  '取每行
            If m <> 0 Then
                n = n + Val(m)
                js = js + 1
            End If
        Next i
        r = n / js
        msg = MsgBox("有效值：" & Str(js) & vbCrLf & "求和值：" & Str(n) & vbCrLf & "平均值：" & Val(r), , "计算结果")
    Case "首个"
        SSTab.Tab = 0
    Case "末个"
        i = SSTab.Tabs
        SSTab.Tab = i - 1
    End Select
End Sub

Private Sub undo_Click()
    Call 撤销_Click
End Sub

Private Sub 半角转全角_Click()
    With RichTextBox
        If .SelText = "" Then
            .Text = StrConv(.Text, 4)    '8为将双字节转换为单字节，4为单字节到双字节
        Else
            .SelText = StrConv(.SelText, 4)    '1转换为大写，2转换为小写
        End If
    End With
End Sub

Private Sub 帮助_Click()
    Load Form4
    Form4.Visible = True
End Sub

Private Sub 保存_Click()
    CommonDialog1.CancelError = True
    CommonDialog1.FileName = ""
    CommonDialog1.DefaultExt = "txt"
    On Error GoTo label

    Dim fname As String, i As Integer
    i = SSTab.Tab
    If RichTextBox.Text = "" Then Exit Sub
    fname = Tsys(i, 1)

    If Tsys(i, 1) <> "" Then                                 '已有文件名的取原文件名
        If Tsys(i, 3) = "T" Then
            RichTextBox.SaveFile fname, rtfText
        Else
            With CommonDialog1
                .Filter = "文本文件|*.txt|所有文件|*.*)"
                .InitDir = mydocments
                fname = Tsys(i, 1)
                .FileName = fname
                .ShowSave
                RichTextBox.SaveFile .FileName, rtfText        ' rtfText参数不可少，否则默认保存为RTF格式
                Tsys(i, 3) = "T"
            End With
        End If
    End If

    If Tsys(i, 1) = "" Then
        If RichTextBox.SelText <> "" Then                       '其次取选中的文本作文件名
            With CommonDialog1
                .Filter = "文本文件|*.txt|所有文件|*.*)"
                .InitDir = mydocments
                .FileName = RichTextBox.SelText
                .ShowSave
                RichTextBox.SaveFile .FileName, rtfText
                Tsys(i, 3) = "T"
                Tsys(i, 0) = Left(.FileTitle, 5)
                Tsys(i, 1) = .FileName
                SSTab.Caption = Left(.FileTitle, 5)
                StatusBar1.Panels(2) = "文件名：" & .FileName       '在状态栏中显示文章数及全文件名
            End With
            Exit Sub
        End If

        sn = InStr(RichTextBox.Text, Chr(13))
        If sn > 0 Then
            fline = Left(RichTextBox.Text, sn - 1)                '再次取首行作文件名
            If fline = "" Then
                fline = Left$(RichTextBox.Text, 10)
            End If

            With CommonDialog1
                .Filter = "文本文件|*.txt|所有文件|*.*)"
                .InitDir = mydocments
                .FileName = fline
                .ShowSave
                RichTextBox.SaveFile .FileName, rtfText
                Tsys(i, 3) = "T"
                Tsys(i, 0) = Left(.FileTitle, 5)
                Tsys(i, 1) = .FileName
                SSTab.Caption = Left(.FileTitle, 5)
                StatusBar1.Panels(2) = "文件名：" & .FileName       '在状态栏中显示文章数及全文件名
            End With
        Else
            With CommonDialog1
                .Filter = "文本文件|*.txt|所有文件|*.*)"
                .InitDir = mydocments
                .ShowSave
                RichTextBox.SaveFile .FileName, rtfText
                Tsys(i, 3) = "T"
                Tsys(i, 0) = Left(.FileTitle, 5)
                Tsys(i, 1) = .FileName
                SSTab.Caption = Left(.FileTitle, 5)
                StatusBar1.Panels(2) = "文件名：" & .FileName       '在状态栏中显示文章数及全文件名
            End With
        End If
    End If
    RichTextBox.SetFocus
label:
    If Err.Number = vbCancel Then
        Exit Sub
    End If

End Sub

Private Sub 背景色_Click()
    CommonDialog1.ShowColor
    RichTextBox.BackColor = CommonDialog1.Color
End Sub

Private Sub 插入日期_Click()
    RichTextBox.SelText = "【" & Date & "  " & Time & "】"
End Sub

Private Sub 查找_Click()
    Load Form3
    Form3.Visible = True
End Sub

Private Sub 打开_Click()
    On Error GoTo label               '设置错误处理陷阱
    CommonDialog1.CancelError = True  '允许截获取消错误'响应取消事件，默认为False
    Dim strOpen As String             '定义字符型变量strOpen，用于存放文件名
    Dim shortfn As String             '定义短文件名,用于tabcaption
    Dim shortfnn As String


    With CommonDialog1
        '    MsgBox Environ("userprofile") & "/My Documents"    '获取我的文档路径文本作为初始目录
        .InitDir = Environ("userprofile") & "/My Documents"

        .Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"  '设置文件过滤
        .DefaultExt = "txt"
        .FilterIndex = 1                      '设置默认的过滤文件为 *.txt

        .FileName = ""
        .ShowOpen                             '调用打开文件对话框，选择要打开的文件
        strOpen = .FileName                   '将指定文件名赋给变量strOpen
        CurFileName = .FileName               '赋值给全局变量供切换子程序调用

        If RichTextBox.Text <> "" Then
            Call 新建_Click
        End If

        RichTextBox.LoadFile strOpen          '用 LoadFile 方法打开strOpen中的文件
        'RichTextBox.FileName= .FileName      '另一种打开文件的方式
        'SSTab.Caption = .FileTitle           '显示完整的文件标题


        If (strOpen <> "") Then
            shortfn = Left(.FileTitle, Len(.FileTitle) - 4)    '不显示扩展名
            shortfnn = Left(shortfn, 5)     '显示标题最长取5个字
            If StrLen(shortfnn) < 8 Then
                shortfnn = Left(shortfn, 10)
            End If
        End If
        SSTab.Caption = shortfnn

    End With
    With SSTab
        curtab = .Tab
        Tsys(curtab, 0) = .Caption
        Tsys(curtab, 1) = strOpen
        Tsys(curtab, 2) = RichTextBox.Text
        Tsys(curtab, 3) = "T"
    End With
    StatusBar1.Panels(2) = "文件名：" & strOpen         '在状态栏中显示文件数及全文件名
    StatusBar1.Panels(1) = "文章数：" & 1 + SSTab.Tab & "/" & SSTab.Tabs
    RichTextBox.SetFocus
label:
    If Err.Number = cdlCancel Then
        Exit Sub
    End If

End Sub

Private Sub 大写转小写_Click()
    With RichTextBox
        If .SelText = "" Then
            .Text = LCase(.Text)
        Else
            .SelText = LCase(.SelText)
        End If
    End With
End Sub

Private Sub 段后插入空行_Click()
    Dim a() As String
    Dim sel As Boolean
    With RichTextBox
        If .SelText = "" Then
            sel = False
        Else
            sel = True
        End If

        If sel = False Then
            a() = Split(.Text, vbCrLf)
        Else
            a() = Split(.SelText, vbCrLf)
        End If

        For i = 0 To UBound(a)
            If a(i) <> "" Then
                tt = tt & a(i) & vbCrLf & vbCrLf
            Else
                tt = tt & ""
            End If
        Next i

        If sel = False Then
            .Text = ""
            .Text = tt
        Else
            .SelText = tt
        End If
    End With

End Sub

Private Sub 关于_Click()
    i = MsgBox("胡子高级记事本VB版 v1.0" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "  胡子软件工作室出品", , "关于……")
End Sub

Private Sub 另存为_Click()
    On Error GoTo label
    CommonDialog1.DefaultExt = "txt"
    CommonDialog1.CancelError = True            '设置陷阱
    Dim fname As String, i As Integer
    i = SSTab.Tab
    fname = Tsys(i, 1)

    If Tsys(i, 1) <> "" Then
        With CommonDialog1
            .Filter = "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*)"
            .InitDir = mydocments
            fname = Tsys(i, 1)
            .FileName = fname
            .ShowSave
            RichTextBox.SaveFile .FileName, rtfText
            Tsys(i, 3) = "T"
        End With
    End If

    If Tsys(i, 1) = "" Then
        If RichTextBox.SelText <> "" Then        '取选中的文本作文件名
            With CommonDialog1
                .Filter = "文本文件|*.txt|所有文件|*.*)"
                .InitDir = mydocments
                .FileName = RichTextBox.SelText
                .ShowSave
                RichTextBox.SaveFile .FileName, rtfText
                Tsys(i, 3) = "T"
                Tsys(i, 0) = Left(.FileName, 5)
                Tsys(i, 1) = .FileName
                StatusBar1.Panels(2) = "文件名：" & .FileName       '在状态栏中显示文章数及全文件名
            End With
            Exit Sub
        End If

        sn = InStr(RichTextBox.Text, Chr(13))
        If sn > 0 Then
            fline = Left(RichTextBox.Text, sn - 1)  '取首行作文件名
            With CommonDialog1
                .Filter = "文本文件|*.txt|所有文件|*.*)"
                .InitDir = mydocments
                .FileName = fline
                .ShowSave
                RichTextBox.SaveFile .FileName, rtfText
                Tsys(i, 3) = "T"
                Tsys(i, 0) = Left(.FileName, 5)
                Tsys(i, 1) = .FileName
                StatusBar1.Panels(2) = "文件名：" & .FileName       '在状态栏中显示文章数及全文件名
            End With
        Else
            With CommonDialog1
                .Filter = "文本文件|*.txt|所有文件|*.*)"
                .InitDir = mydocments
                .ShowSave
                RichTextBox.SaveFile .FileName, rtfText
                Tsys(i, 3) = "T"
                Tsys(i, 0) = Left(.FileName, 5)
                Tsys(i, 1) = .FileName
                StatusBar1.Panels(2) = "文件名：" & .FileName       '在状态栏中显示文章数及全文件名
            End With
        End If
    End If

label:
    If Err.Number = vbCancel Then
        Exit Sub
    End If

End Sub

Private Sub 前景色_Click()
    CommonDialog1.ShowColor
    RichTextBox.SelColor = CommonDialog1.Color
End Sub

Private Sub 全角转半角_Click()
    With RichTextBox
        If .SelText = "" Then
            .Text = StrConv(.Text, 8)    '8为将双字节转换为单字节，4为单字节到双字节
        Else
            .SelText = StrConv(.SelText, 8)
        End If
    End With
End Sub

Private Sub 全选并复制_Click()
    Call 全选_Click
    Call 复制_Click
End Sub

Private Sub 删除换行符_Click()
    Dim a() As String
    With RichTextBox
        If .SelText = "" Then
            a() = Split(.Text, vbCrLf)
        Else
            a() = Split(.SelText, vbcrtlf)
        End If
        For i = 0 To UBound(a)
            If a(i) <> "" Then
                tt = tt & Replace(a(i), vbCrLf, "")
            Else
                tt = tt & vbCrLf & vbCrLf
            End If
        Next i
        If .SelText = "" Then
            .Text = ""
            .Text = tt
        Else
            .SelText = tt
        End If
    End With
End Sub

Private Sub 删除空行_Click()
    Dim linetxt() As String
    With RichTextBox
        If .SelText = "" Then
            linetxt() = Split(.Text, vbCrLf)
            .Text = ""
            For i = 0 To UBound(linetxt)
                If linetxt(i) <> "" Then
                    .Text = .Text & linetxt(i) & vbCrLf
                End If
            Next i
        Else
            linetxt() = Split(.SelText, vbCrLf)
            .SelText = ""
            For i = 0 To UBound(linetxt)
                If linetxt(i) <> "" Then
                    .SelText = linetxt(i) & vbCrLf
                End If
            Next i
        End If
    End With
End Sub

Private Sub 删除同类字符_Click()
    Dim tt As String
    With RichTextBox
        If .SelText <> "" Then
            tt = Replace(.Text, .SelText, "")  '这里的.seltext前面的小点丢了，检查了一天没查出来
            .Text = ""
            .Text = tt
        End If
    End With
End Sub

Private Sub 删除行首空格_Click()
    Dim ftt() As String
    With RichTextBox
        If .SelText = "" Then
            ftt() = Split(.Text, vbCrLf)
            .Text = ""
            For i = 0 To UBound(ftt)
                If ftt(i) <> "" Then
                    .Text = .Text & Trim(ftt(i)) & vbCrLf
                End If
            Next i
        Else
            ftt() = Split(.SelText, vbCrLf)
            .SelText = ""
            For i = 0 To UBound(ftt)
                If ftt(i) <> "" Then
                    .SelText = Trim(ftt(i)) & vbCrLf
                End If
            Next i
        End If
    End With
End Sub

Private Sub 小写转大写_Click()
    With RichTextBox
        If .SelText = "" Then
            .Text = UCase(.Text)
        Else
            .SelText = UCase(.SelText)
        End If
    End With
End Sub

Private Sub 新建_Click()
    On Error GoTo label
    Dim tabn As Integer, curtab As Integer, nexttab As Integer
    With SSTab
        If .Tabs < 10 Then
            curtab = .Tabs
            curtab = curtab - 1
            Tsys(curtab, 0) = .Caption
            'Tsys(curtab, 1) = CurFileName
            Tsys(curtab, 2) = RichTextBox.Text
            'Tsys(curtab, 3) = "F"                  '以上保存前一个文本信息到数组
            RichTextBox.Text = ""
            CurFileName = ""

            .Tabs = .Tabs + 1
            nexttab = .Tabs
            .Tab = nexttab - 1
            .Caption = "新文件" & .Tabs
            Tsys(nexttab - 1, 0) = .Caption
            Tsys(nexttab - 1, 1) = ""
            Tsys(nexttab - 1, 2) = ""
            Tsys(nexttab - 1, 3) = "F"             '以上保存新建文件信息到数组

            StatusBar1.Panels(2) = "文件名："      '在状态栏中显示文件数及全文件名
            StatusBar1.Panels(1) = "文章数：" & 1 + SSTab.Tab & "/" & SSTab.Tabs
        Else
            msg = MsgBox("对不起，最多允许可以同时打开10个文件", , "提示信息")
        End If
    End With
    RichTextBox.SetFocus                       '编辑框获取焦点
label:
    Exit Sub
End Sub


Private Sub 全选_Click()
    With RichTextBox
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
End Sub


Private Sub 剪切_Click()
    If RichTextBox.SelText <> "" Then
        Clipboard.Clear
        Clipboard.SetText RichTextBox.SelText, vbCFText
        RichTextBox.SelText = ""
    End If
End Sub


Private Sub 行首缩进_Click()
    Dim a() As String
    Dim sel As Boolean
    With RichTextBox
        If .SelText = "" Then
            sel = False
        Else
            sel = True
        End If

        If .SelText = "" Then
            a() = Split(.Text, vbCrLf)
        Else
            a() = Split(.SelText, vbCrLf)
        End If

        For i = 0 To UBound(a)
            If a(i) <> "" Then
                tt = tt & "　　" & a(i) & vbCrLf  '两个全角空格
            Else
                tt = tt & vbCrLf
            End If
        Next i

        If sel = False Then
            .Text = ""
            .Text = tt
        Else
            .SelText = tt
        End If
    End With


End Sub

Private Sub 粘贴_Click()
    RichTextBox.SelText = Clipboard.GetText
End Sub

Private Sub 复制_Click()
    VB.Clipboard.Clear
    Clipboard.SetText RichTextBox.SelText, vbCFText
End Sub

Private Sub 撤销_Click()
    SendKeys "^Z"
End Sub


Private Sub 删除_Click()
    RichTextBox.SelText = ""
End Sub

Private Sub 退出_Click()
'End
    Unload Me
End Sub

Private Sub SetOnTop(ByVal IsOnTop As Boolean)
    Dim rtn As Long
    If IsOnTop = True Then        '将窗口置于最上面
        rtn = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)
    Else
        rtn = SetWindowPos(Me.hwnd, -2, 0, 0, 0, 0, 3)
    End If
End Sub

Private Sub wordopen()
    Dim oApp As Word.Application
    Dim oDoc As Word.Document
    Dim Content As String   '保存内容的字符串

    'RichTextBox.SaveFile "c:/temp.txt"
    '打开需要的文件
    Set oApp = CreateObject("Word.Application")
    oApp.Visible = True
    Set oDoc = oApp.Documents.Add
    oDoc.Content.Text = RichTextBox.Text
End Sub

Private Sub 字数行数统计_Click()
    Dim a() As String
    Dim b() As String
    Dim sel As Boolean
    With RichTextBox
        If .SelText = "" Then
            sel = False
        Else
            sel = True
        End If

        .HideSelection = False  '保持文本选中状态
        RichTextBox.SetFocus    '重新获取焦点
        If sel = True Then
            b() = Split(.SelText, vbCrLf)
            msg = MsgBox("字符数：" & Str(Len(.SelText)) & vbCrLf & vbCrLf & "行  数：" & UBound(b) + 1, , "统计信息")
        Else
            a() = Split(.Text, vbCrLf)
            msg = MsgBox("字符数：" & Str(Len(.Text)) & vbCrLf & vbCrLf & "行  数：" & UBound(a) + 1, , "统计信息")
        End If
    End With
End Sub

Private Sub 字体_Click()
'CommonDialog1.ShowFont
    Call RichTextBox_DblClick
    '  With CommonDialog1
    '    CommanDialog1.Flags = cdlCFBoth '或设为cdlCFPrinterFonts Or cdlCFScreenFonts
    '    .ShowFont
    '    CommonDialog1.Flags = &H3 Or &H100
    '    If IsNull(Text1.SelFontName) = True Then
    '      CommonDialog1.FontName = "宋体"  '当您选择了混合字体时SelFontName为空
    '    Else
    '      CommonDialog1.FontName = Text1.SelFontName
    '    End If
    '    CommonDialog1.FontSize = Text1.SelFontSize
    '    CommonDialog1.FontBold = Text1.SelBold
    '    CommonDialog1.FontItalic = Text1.SelItalic
    '    CommonDialog1.Color = Text1.SelColor
    '    CommonDialog1.FontStrikethru = Text1.SelStrikeThru
    '    CommonDialog1.FontUnderline = Text1.SelUnderline
    '    CommonDialog1.ShowFont
    '    If Err <> cdlCancel Then
    '      Text1.SelFontName = CommonDialog1.FontName
    '      Text1.SelFontSize = CommonDialog1.FontSize
    '      Text1.SelBold = CommonDialog1.FontBold
    '      Text1.SelItalic = CommonDialog1.FontItalic
    '      Text1.SelColor = CommonDialog1.Color
    '      Text1.SelStrikeThru = CommonDialog1.FontStrikethru
    '      Text1.SelUnderline = CommonDialog1.FontUnderline
    '    End If
    '  End With
End Sub

Private Sub 自动折行_Click()
'  RichTextBox.MultiLine = Not RichTextBox.MultiLine
    RichTextBox.MultiLine = False
End Sub

Private Sub 总在最前面_Click()
    Dim rtn As Long
    If ontop = False Then        '将窗口置于最上面
        rtn = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)
        ontop = True
    Else
        rtn = SetWindowPos(Me.hwnd, -2, 0, 0, 0, 0, 3)
        ontop = False
    End If

End Sub

━━━━━━━━━━━━━━━━━━━━━━━━━━
form2

Private 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
'总在最上面的API

Private Sub Command1_Click()
    List1.Clear
End Sub

Private Sub Command2_Click()
    Form2.Visible = False
End Sub

Private Sub Form_Click()
    Dim ontop As Long
    '将窗口置于最上面
    ontop = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)

End Sub

Private Sub Form_Load()
    Dim ontop As Long
    '将窗口置于最上面
    ontop = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)

End Sub

Private Sub List1_Click()
    i = List1.ListIndex    '选中项的索引
    t = List1.Text
    If i <> 0 Then List1.RemoveItem (i)
    Clipboard.SetText t
End Sub

Private Sub List1_DblClick()
    Form1.RichTextBox.SelText = Clipboard.GetText
End Sub

━━━━━━━━━━━━━━━━━━━━━━━━━━
form3

Option Explicit  '定义目标位置变量
Private fpc As Integer
Private 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
'总在最上面的API

Private Sub Command4_Click()
    Unload Me
    Form1.StatusBar1.Panels(2) = Tsys(Form1.SSTab.Tab, 1)        '在状态栏中显示信息
End Sub

Private Sub Form_Click()
    Dim ontop As Long
    '将窗口置于最上面
    ontop = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)

End Sub

Private Sub Form_Load()
    Dim ontop As Long
    Dim bc As String
    '将窗口置于最上面
    ontop = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)
    If Form1.RichTextBox.SelText <> "" Then
        bc = Form1.RichTextBox.SelText
        Text1.Text = bc
    End If

End Sub


Private Sub Command1_Click()
    FindText 1
End Sub

Private Sub FindText(ByVal fstart As Integer)
    Dim pos As Integer
    Dim i
    If Check1.Value = False Then
        pos = InStr(fstart, Form1.RichTextBox.Text, Text1.Text, 1)     '1为不区分大小写
    Else
        pos = InStr(fstart, Form1.RichTextBox.Text, Text1.Text, 0)
    End If

    If pos > 0 Then
        fpc = pos
        Form1.RichTextBox.SelStart = fpc - 1
        Form1.RichTextBox.SelLength = Len(Text1.Text)        '选中找到的字符串
        Form1.RichTextBox.SetFocus
    Else
        'i = MsgBox("  没有找到！  ", vbOKOnly, "查找")
        Form1.StatusBar1.Panels(2) = "◆◆◆找不到！还是没有了？"         '在状态栏中显示信息
        Form1.RichTextBox.SetFocus
    End If
End Sub

Private Sub Command2_Click()
    FindText fpc + 1
End Sub

Private Sub Command3_Click()
    Dim tt As String
    Dim i
    If Check1.Value = True Then
        tt = Replace(Form1.RichTextBox.Text, Text1.Text, Text2.Text, , , vbTextCompare)
    Else
        tt = Replace(Form1.RichTextBox.Text, Text1.Text, Text2.Text)
    End If
    Form1.RichTextBox.Text = ""
    Form1.RichTextBox.Text = tt
    Form3.SetFocus
    'i = MsgBox("全部替换完毕！", vbOKOnly, "信息")
    Form1.StatusBar1.Panels(2) = "◆◆◆全部替换完毕！"         '在状态栏中显示信息
End Sub


━━━━━━━━━━━━━━━━━━━━━━━━━━
form4

Option Explicit  '定义目标位置变量
Private fpc As Integer
Private 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
'总在最上面的API


Private Sub Form_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Dim ontop As Long              '将窗口置于最上面
    ontop = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)

    Transparency = 255 - 80
    Translucence Me
    Label1.BackStyle = 0  '标签背景透明
    Label1.ForeColor = RGB(255, 229, 184)
    Label2.ForeColor = vbBlue
    Label3.ForeColor = QBColor(2)
    Label4.ForeColor = QBColor(0)  '显示16色，0-15
End Sub

━━━━━━━━━━━━━━━━━━━━━━━━━━
module1

Option Explicit
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Public Transparency As Integer
Const SWP_NOACTIVATE = 3
Const WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2
Const LWA_COLORKEY = &H1

Sub Translucence(frm As Form)
    Dim rtn As Long
    rtn = GetWindowLong(frm.hwnd, GWL_EXSTYLE)
    rtn = rtn Or WS_EX_LAYERED
    SetWindowLong frm.hwnd, GWL_EXSTYLE, rtn
    SetLayeredWindowAttributes frm.hwnd, 0, Transparency, LWA_ALPHA
End Sub


━━━━━━━━━━━━━━━━━━━━━━━━━━
module2

'public：公用变量，其他模块可调用
Public Tsys(9, 3)          '标题、文件名、文本、保存。(卡号即数组索引)


━━━━━━━━━━━━━━━━━━━━━━━━━━
module3


'取字符串中有多少个字符(1个汉字定义为2个字符宽度)

Public Function StrLen(ByVal s As String) As Integer
    Dim i As Integer
    n = Len(s)
    For i = 1 To n
        If Asc(Mid$(s, i, 1)) < 0 Then n = n + 1     '若为汉字,字符个数加1
    Next i
    StrLen = n
End Function