frmnote.frm

个人记事本

    If Not flag Then
        If RecentCount = 8 Then
            '将 当前数据库名 FName 存入 Recent() 数组末，并删除第一条纪录
            For i = 1 To RecentCount - 1
                Recent(i) = Recent(i + 1)
            Next
            Recent(RecentCount) = FName
        Else
            '将 当前数据库名 FName 存入 Recent() 数组末
            RecentCount = RecentCount + 1
            ReDim Preserve Recent(RecentCount)
            Recent(RecentCount) = FName
        End If
    End If
    
    Open App.Path & "\System\Recent.ini" For Output As #1
    For i = 1 To RecentCount
        Print #1, Recent(i)
    Next
    Close #1
    
'/////////////////////////////////////////////////////////
'////   BMPMenu
    Dim mHandle As Long, IRet As Long, sHandle As Long
    mHandle = GetMenu(hwnd)
    sHandle = GetSubMenu(mHandle, 0)
    IRet = SetMenuItemBitmaps(sHandle, 0, myflage, PicMenuOpen, PicMenuOpen)
    IRet = SetMenuItemBitmaps(sHandle, 1, myflage, PicMenuNew, PicMenuNew)
    IRet = SetMenuItemBitmaps(sHandle, 6, myflage, PicMenuClose, PicMenuClose)
    
    sHandle = GetSubMenu(mHandle, 1)
    IRet = SetMenuItemBitmaps(sHandle, 0, myflage, PicMenuAdd, PicMenuAdd)
    IRet = SetMenuItemBitmaps(sHandle, 1, myflage, PicMenuDel, PicMenuDel)
    IRet = SetMenuItemBitmaps(sHandle, 2, myflage, PicMenuOK, PicMenuOK)
    IRet = SetMenuItemBitmaps(sHandle, 4, myflage, PicMenuSearch, PicMenuSearch)

    sHandle = GetSubMenu(mHandle, 2)
    IRet = SetMenuItemBitmaps(sHandle, 0, myflage, PicMenuUndo, PicMenuUndo)
    IRet = SetMenuItemBitmaps(sHandle, 2, myflage, PicMenuCut, PicMenuCut)
    IRet = SetMenuItemBitmaps(sHandle, 3, myflage, PicMenuCopy, PicMenuCopy)
    IRet = SetMenuItemBitmaps(sHandle, 4, myflage, PicMenuPaste, PicMenuPaste)
    IRet = SetMenuItemBitmaps(sHandle, 7, myflage, PicMenuColor, PicMenuColor)
    IRet = SetMenuItemBitmaps(sHandle, 8, myflage, PicMenuFont, PicMenuFont)
    IRet = SetMenuItemBitmaps(sHandle, 9, myflage, PicMenuSearch, PicMenuSearch)
    
    sHandle = GetSubMenu(mHandle, 3)
    IRet = SetMenuItemBitmaps(sHandle, 2, myflage, PicMenuOption, PicMenuOption)
    
    sHandle = GetSubMenu(mHandle, 4)
    IRet = SetMenuItemBitmaps(sHandle, 0, myflage, PicMenuHelp, PicMenuHelp)
    IRet = SetMenuItemBitmaps(sHandle, 2, myflage, PicMenuEmail, PicMenuEmail)
    IRet = SetMenuItemBitmaps(sHandle, 3, myflage, PicMenuWeb, PicMenuWeb)
    IRet = SetMenuItemBitmaps(sHandle, 5, myflage, PicMenuNote, PicMenuNote)
    
'/////////////////////////////////////////////////////////
'////        for 查找
    For i = 0 To n - 1
        Combo.AddItem Search(i), i
    Next
    
    loadfinished = True
End Sub

Private Sub Form_Initialize()
    Dim strtmp As String
    With Data1
        If .Recordset.RecordCount = 0 Then
            CmdDel.Enabled = False
            Me.menuOperatDel.Enabled = False
            strtmp = "0/0"
            .Caption = Space(6 - Len(strtmp) / 2) + strtmp
            txtSubject.Enabled = False
            RTFMatter.Enabled = False
        Else
            .Recordset.MoveLast
            .Recordset.MoveFirst
            '载入listSubject的列表
            listSubject.Clear
            Do Until .Recordset.EOF = True
                listSubject.AddItem (txtSubject.Text)
                .Recordset.MoveNext
            Loop
            .Recordset.MoveFirst
    
            strtmp = Str(.Recordset.AbsolutePosition + 1) & "/" & Str(.Recordset.RecordCount)
            .Caption = Space(6 - Len(strtmp) / 2) + strtmp
            CmdDel.Enabled = True
            Me.menuOperatDel.Enabled = True
        End If
    End With
End Sub

Private Sub Form_Resize()
'使各控件充满文本框
    '调整各控件宽度
    If ScaleWidth - 2240 > 800 Then
        listSubject.Width = ScaleWidth - 240
        txtSubject.Width = ScaleWidth - 2260
        txtEditTime.left = txtSubject.Width + 190
        RTFMatter.Width = ScaleWidth - 240
    End If
    
    '调整各控件高度
    If ScaleHeight - 3250 > 0 Then
        RTFMatter.Height = ScaleHeight - 3250
    End If
End Sub

Private Sub CmdAdd_Click()
    txtSubject.Enabled = True
    RTFMatter.Enabled = True
    
    '【 Note 工程 】日记 12
    If Data1.Recordset.RecordCount Then Data1.Recordset.MoveFirst
    
    Data1.Recordset.AddNew
    txtSubject.SetFocus
    CmdDel.Enabled = False
    menuOperatDel.Enabled = False
    '禁止查找
    If CmdList.Visible Then CmdList_Click
    Me.CmdToSearch.Enabled = False
    Me.menuOperatSearch.Enabled = False
    
    Data1.Caption = ""
    add = True      'for update
End Sub

Private Sub CmdOK_Click()
    '容错
    If Data1.Recordset.RecordCount = 0 And add = False Then
        MsgBox "无当前记录", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    End If
    
    ok = True      'for update
    If add Then
        Data1.Recordset.Update
        Data1.Recordset.MoveLast    '【 Note 工程 】日记 4
    Else
        Data1.Recordset.Move (0)
    End If
End Sub

Private Sub CmdToSearch_Click()
    '容错
    If Data1.Recordset.RecordCount = 0 Then
        MsgBox "无记录", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    End If

    Frame1.Visible = True
    listSubject.Visible = False
    menuOperatSearch.Enabled = False
    CmdList.Visible = True
    CmdToSearch.Visible = False
End Sub

Private Sub CmdList_Click()
    Frame1.Visible = False
    listSubject.Visible = True
    menuOperatSearch.Enabled = True
    CmdList.Visible = False
    CmdToSearch.Visible = True
End Sub

Private Sub CmdDel_Click()
    Dim Msg As Integer, temp As Integer
    Msg = MsgBox("确实要删除当前记录吗？", vbYesNo, "删除确认")
    If Msg = vbYes Then
        With Data1.Recordset
             '更新listSubject列表
            temp = .AbsolutePosition
            listSubject.RemoveItem (temp)
            .Delete
            .MoveNext
            If .RecordCount = 0 Then
                txtSubject.Enabled = False
                RTFMatter.Enabled = False
                Exit Sub
            End If
            If .EOF Then .MoveLast
        End With
    End If
End Sub

Private Sub Data1_Reposition()
    Dim strtmp As String
    With Data1
        If .Recordset.RecordCount = 0 Then
            CmdDel.Enabled = False
            Me.menuOperatDel.Enabled = False
            strtmp = "0/0"
            .Caption = Space(6 - Len(strtmp) / 2) + strtmp
        Else
            strtmp = Str(.Recordset.AbsolutePosition + 1) & "/" & Str(.Recordset.RecordCount)
            .Caption = Space(6 - Len(strtmp) / 2) + strtmp
            CmdDel.Enabled = True
            Me.menuOperatDel.Enabled = True
        End If
    End With
        
    If loadfinished Then
        If Not Me.txtflag.Text = "1" Then
            Me.txtSubject.Enabled = True
            Me.RTFMatter.Enabled = True
        Else
            Me.txtSubject.Enabled = False
            Me.RTFMatter.Enabled = False
        End If
    End If
End Sub

Private Sub Data1_Validate(Action As Integer, Save As Integer)
    Dim Msg As Integer
    Select Case Action
        Case 1, 2, 3, 4, 5, 6, 11, 15:
        ' 1  *    调用 MoveFirst 方法
        ' 2  *    调用 MovePrevious 方法
        ' 3  *    调用 MoveNext 方法
        ' 4  *    调用 MoveLast 方法
        ' 5  *    调用 AddNew 方法
        ' 6  *    调用 Update 方法
        ' 7      调用 Dllete 方法
        ' 8      调用 Find 方法
        ' 9      调用 BookMark 方法
        ' 10     调用 Close 方法
        ' 11 *    调用 Unload 方法
        ' 15 *    调用 Move 方法
            If add Then '如果新建记录且添加了内容就强制保存
                        '【 Note 工程 】Bug 解决方法   9
                txtEditTime.Text = CStr(Now) '存入最后修改时间
                '更新listSubject列表
                listSubject.AddItem (txtSubject.Text)
                txtflag.Text = 0       '初始记录标志
                add = False         '恢复 add 标志
                ok = False      '如果上一步是 cmdOK ,恢复 ok 标志
                '恢复查找功能
                CmdToSearch.Enabled = True
                menuOperatSearch.Enabled = True
                Exit Sub
            End If
            If Save Then
                If ok Then      '如果上一步是确认，不用询问数据是否要更新
                    Msg = vbYes
                Else
                    Msg = MsgBox("数据要更新吗？", vbYesNo, "操作确认")
                End If
                
                If Msg = vbNo Then
                    Save = 0
                Else
                    txtEditTime.Text = CStr(Now) '存入最后修改时间
                    '更新listSubject列表
                    Dim temp As Integer
                    temp = Data1.Recordset.AbsolutePosition
                    listSubject.RemoveItem (temp)
                    listSubject.AddItem txtSubject.Text, temp
                End If
            End If
        If ok Then ok = False      '如果上一步是 cmdOK ,恢复 ok 标志
    End Select
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DBCount = DBCount - 1
End Sub

Private Sub listSubject_Click()
    'VB 中的 Move 的参数为相对位置
    If add Then Data1.Recordset.Update
    Data1.Recordset.Move (listSubject.ListIndex - Data1.Recordset.AbsolutePosition)
End Sub

'/////////////////////////////////////////////////////////////////////////
'//     菜单
'//         文件
Private Sub menuFileOpen_Click()
    CommonDialog1.FileName = ""
    CommonDialog1.InitDir = QueryValue(HKEY_CURRENT_USER, "Software\Note", "TacitlySaveFolder")
    CommonDialog1.Filter = "Note Files (*.not)|*.not"
    CommonDialog1.CancelError = True    '按“取消”，产生错误信息
    On Error GoTo OpenCancelerr
    CommonDialog1.ShowOpen
    FName = CommonDialog1.FileName  '将打开的文件名存入FName
    
    If Dir(FName) = "" Then
        MsgBox FName & "已不存在", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    End If
    
    Dim frmD As New frmNote         '建立一个窗口 note 的实例
    frmD.Show
    DBCount = DBCount + 1
OpenCancelerr:
End Sub

Private Sub menuFileNew_Click()
    CommonDialog1.FileName = ""
    CommonDialog1.InitDir = QueryValue(HKEY_CURRENT_USER, "Software\Note", "TacitlySaveFolder")
    CommonDialog1.Filter = "Note Files (*.not)|*.not"
    CommonDialog1.CancelError = True    '按“取消”，产生错误信息
    On Error GoTo OpenCancelerr
    CommonDialog1.ShowOpen
    FName = CommonDialog1.FileName  '将打开的文件名存入FName
    
    If Not Dir(FName) = "" Then     '如果文件已存在，询问是否覆盖
        If MsgBox(FName & "文件已存在，是否覆盖？", vbYesNo + _
            vbExclamation, "提示信息") = vbNo Then Exit Sub
    End If
    
    FileCopy App.Path & "\System\model.not", FName '通过复制数据库model.not 建立新数据库
    Dim frmD As New frmNote         '建立一个窗口 note 的实例
    frmD.Show
    DBCount = DBCount + 1
OpenCancelerr:
End Sub

Private Sub menuFileSaveAs_Click()
    '容错
    If Data1.Recordset.RecordCount = 0 Then
        MsgBox "无当前记录", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    End If
    
    CommonDialog1.FileName = txtSubject.Text
    CommonDialog1.InitDir = QueryValue(HKEY_CURRENT_USER, "Software\Note", "TacitlySaveFolder")
    CommonDialog1.Filter = "文本文件(*.txt)|*.txt|rtf 文件(*.rtf)|*.rtf"
    CommonDialog1.FilterIndex = 1
    CommonDialog1.CancelError = True
    On Error GoTo err
    CommonDialog1.ShowSave
    Open CommonDialog1.FileName For Output As #1
    If right(CommonDialog1.FileName, 3) = "txt" Then
        Print #1, txtSubject.Text & Chr(13) & Chr(10) & RTFMatter.Text
    ElseIf right(CommonDialog1.FileName, 3) = "rtf" Then
        Print #1, RTFMatter.TextRTF
    End If
    Close #1
err:
    Exit Sub
End Sub

Private Sub menuFileRecent_Click(Index As Integer)
    FName = Recent(RecentCount - Index + 1)  '将打开的文件名存入FName
    
    If Dir(FName) = "" Then
        MsgBox FName & "已不存在", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    End If
    
    Dim frmD As New frmNote         '建立一个窗口 note 的实例
    frmD.Show
    DBCount = DBCount + 1
End Sub

Private Sub menuFileCloseDatabase_Click()
    Unload Me
End Sub

'//////////////////////////////////
'////           记录操作
Private Sub menuOperatAdd_Click()
    CmdAdd_Click
End Sub