frmnote.frm

个人记事本

Private Sub menuOperatDel_Click()
    CmdDel_Click
End Sub

Private Sub menuOperatOK_Click()
    CmdOK_Click
End Sub

Private Sub menuOperatSearch_Click()
    CmdToSearch_Click
End Sub

'//////////////////////////////////
'////           编辑
Private Sub menuEditUndo_Click()
    SendKeys "^z", True
End Sub
Private Sub menuEditCopy_Click()
    SendKeys "^c", True
End Sub
Private Sub menuEditCut_Click()
    SendKeys "^x", True
End Sub
Private Sub menuEditPaste_Click()
    SendKeys "^v", True
End Sub
Private Sub menuEditAll_Click()
    SendKeys "^a", True
End Sub

Private Sub menuEditFont_Click()
    CommonDialog1.flags = 1 + 256       '只列出屏幕字体
    CommonDialog1.CancelError = True
    If Not RTFMatter.SelFontName = Null Then CommonDialog1.FontName = RTFMatter.SelFontName '字体名称
    If Not RTFMatter.SelBold = Null Then CommonDialog1.FontBold = RTFMatter.SelBold                     '字体粗体
    If Not RTFMatter.SelFontSize = Null Then CommonDialog1.FontSize = RTFMatter.SelFontSize  '字体大小
    If Not RTFMatter.SelItalic = Null Then CommonDialog1.FontItalic = RTFMatter.SelItalic  '字体斜体
    If Not RTFMatter.SelStrikeThru = Null Then CommonDialog1.FontStrikethru = RTFMatter.SelStrikeThru  '删除线
    If Not RTFMatter.SelUnderline = Null Then CommonDialog1.FontUnderline = RTFMatter.SelUnderline    '下划线
    If Not RTFMatter.SelColor = Null Then CommonDialog1.Color = RTFMatter.SelColor       '字体颜色
    On Error GoTo CancelError
    
    CommonDialog1.ShowFont
    RTFMatter.SelFontName = CommonDialog1.FontName  '字体名称
    RTFMatter.SelBold = CommonDialog1.FontBold      '字体粗体
    RTFMatter.SelFontSize = CommonDialog1.FontSize  '字体大小
    RTFMatter.SelItalic = CommonDialog1.FontItalic  '字体斜体
    RTFMatter.SelStrikeThru = CommonDialog1.FontStrikethru  '删除线
    RTFMatter.SelUnderline = CommonDialog1.FontUnderline    '下划线
    RTFMatter.SelColor = CommonDialog1.Color        '字体颜色
CancelError:
End Sub

Private Sub menuEditColour_Click()
    CommonDialog1.CancelError = True
    On Error GoTo CancelError
    
    CommonDialog1.ShowColor
    RTFMatter.SelColor = CommonDialog1.Color        '字体颜色
CancelError:
End Sub

Private Sub menuEditEncrypt_Click()
    '容错
    If add Then
        MsgBox "新建纪录后要先保存后，才可加密", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    ElseIf Data1.Recordset.RecordCount = 0 Then
        MsgBox "无当前记录", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    ElseIf txtflag.Text = 1 Then
        MsgBox "当前记录已被加密", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    End If
    
    
'获得密码
    Dim code As String, letter As String, strtmp As String
    Dim i As Long, charsInFile As Long
    
    'get encryption code and use it to encrypt file
    code = InputBox("请输入密码：", , "xujiayong")
    If code = "" Then Exit Sub  'if Cancel chosen, exit sub
    
    MousePointer = 11     'display hourglass
    
    Dim PASSWORD() As Long  '定义数组用于存放密码的ASCII码
    Dim password_len As Integer
    
    password_len = Len(code)
    ReDim PASSWORD(password_len) As Long
    For i = 0 To password_len - 1 '把密码转化为ASCII码
        PASSWORD(i) = Asc(Mid(code, i + 1, 1))
    Next
    
    '加密
    charsInFile = Len(Me.RTFMatter.TextRTF) 'find string length
    For i = 1 To charsInFile  'for each character in file
        letter = Mid(Me.RTFMatter.TextRTF, i, 1) 'read next char
        'convert to number w/ Asc, then use Xor to encrypt
        strtmp = strtmp & (Asc(letter) Xor PASSWORD((i Mod password_len) + 1)) & " "
        'Print #1, Asc(letter$) Xor code; 'and save in file
    Next i
    'Close #1                'close file when finished
    MousePointer = 0  'reset mouse
    
    '将加密后的文件写入纪录
    Me.RTFMatter.TextRTF = strtmp
    Me.txtSubject.Enabled = False
    Me.RTFMatter.Enabled = False
    '记录 flag =1,标志已加密
    txtflag.Text = 1
End Sub

Private Sub menuEditdecrypt_Click()
    '容错
    If add Then
        MsgBox "新建纪录后要先保存后，才可加密", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    ElseIf Data1.Recordset.RecordCount = 0 Then
        MsgBox "无当前记录", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    ElseIf txtflag.Text = 0 Then
        MsgBox "当前记录未被加密", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    End If
    
'获得密码
    Dim code As String, decrypt As String, e As String
    Dim i As Long, charsInFile As Long, Number As Long
    
    'get encryption code and use it to encrypt file
    code = InputBox("请输入密码：", , "xujiayong")
    If code = "" Then Exit Sub  'if Cancel chosen, exit sub
    
    MousePointer = 11     'display hourglass
    
    Dim PASSWORD() As Long  '定义数组用于存放密码的ASCII码
    Dim password_len As Integer
    
    password_len = Len(code)
    ReDim PASSWORD(password_len) As Long
    For i = 0 To password_len - 1 '把密码转化为ASCII码
        PASSWORD(i) = Asc(Mid(code, i + 1, 1))
    Next
    
    
    '将加密后的文件写入文件 App.System & "system01.txt"
    Open App.Path & "\System\system01.txt" For Output As #1
        Print #1, RTFMatter.Text
    Close #1
    '解密
    
    
    MousePointer = 11 'display hourglass
    Open App.Path & "\System\system01.txt" For Input As #1 'open file
    On Error GoTo Problem:  'set error handler
    decrypt$ = ""   'initialize string for decryption
    i = 1
    Do Until EOF(1)         'until end of file reached
        Input #1, Number&   'read encrypted numbers
        e$ = Chr$(Number& Xor PASSWORD((i Mod password_len) + 1)) 'convert with Xor
        i = i + 1
        decrypt$ = decrypt$ & e$    'and build string
    Loop
    Me.RTFMatter.TextRTF = decrypt$ 'display converted string
    Me.txtSubject.Enabled = True
    Me.RTFMatter.Enabled = True  'and enable scroll bars
CleanUp:                        'when finished...
    MousePointer = 0  'reset mouse
    Close #1                'close file
    
    '记录 flag =0,标志未加密
    txtflag.Text = 0
    '清空 App.Path & "\System\system01.txt"
    Open App.Path & "\System\system01.txt" For Output As #1
        Print #1, ""
    Close #1
    Exit Sub
    
Problem:  'if there is a problem, display appropriate message
    If err.Number = 5 Then  'Chr$ problem means bad key
        MsgBox ("Incorrect Encryption Key")
    Else  'for other problems (like file too big) show error
        MsgBox "Error Opening File", , err.Description
    End If
    Resume CleanUp:   'finally, finish with CleanUp routine
End Sub

'//////////////////////////////////
'////           RTF 右键菜单
Private Sub menuQEditUndo_Click()
    SendKeys "^z", True
End Sub
Private Sub menuQEditCopy_Click()
    SendKeys "^c", True
End Sub
Private Sub menuQEditCut_Click()
    SendKeys "^x", True
End Sub
Private Sub menuQEditPaste_Click()
    SendKeys "^v", True
End Sub
Private Sub menuQEditAll_Click()
    SendKeys "^a", True
End Sub

Private Sub menuQEditFont_Click()
    menuEditFont_Click
End Sub

Private Sub menuQEditColour_Click()
    menuEditColour_Click
End Sub

'//////////////////////////////////
'////           选项
Private Sub menuOptionCipher_Click()
    frmSetPassword.Show (1) '模式窗口
End Sub

Private Sub menuOptionParameter_Click()
    frmSetParameter.Show 1, Me '模式窗口
End Sub

'//////////////////////////////////
'////           帮助
Private Sub menuHelpSubject_Click()
    'help
End Sub

Private Sub menuHelpReadme_Click()
    '得到 windows 文件夹位置
    Dim sPath As String * 260, lLen As Long
    lLen = GetWindowsDirectory(sPath, 260)
    Dim WinDir As String
    WinDir = left(sPath, lLen)
    
    Dim CommandLine As String, x As Long
    CommandLine = WinDir & "\notepad.exe " & App.Path & "\Readme.txt"
    x = Shell(CommandLine, vbNormalFocus)
End Sub

Private Sub menuHelpSentmail_Click()
    sendmail
End Sub

Private Sub menuHelpWeb_Click()
    gotoweb
End Sub

Private Sub menuHelpAbout_Click()
    frmAbout.Show (1)
End Sub

Private Sub RTFMatter_KeyDown(KeyCode As Integer, Shift As Integer)
'///////    输入“Tab”
    If Shift = 2 And KeyCode = 32 Then  'Alt + Tab
        Me.RTFMatter.SelText = 32   '插入“Tab”
    End If
    
    If Shift = 1 And KeyCode = vbKeyF10 Then  'Shift + F10
        Me.PopupMenu menuQEdit, , 5000, 1000   '调用“鼠标右键”事件
    End If
End Sub

Private Sub RTFMatter_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then Me.PopupMenu menuQEdit
End Sub

Private Sub txtSubject_Change()
    '防止“主题”输入超出 50 字节时出错
    '【 Note 工程 】Bug 解决方法 8,1
    If Len(txtSubject.Text) > 48 Then
        txtSubject.Text = left(txtSubject.Text, 48)
        Me.txtSubject.SelStart = 100
    End If
End Sub

'///////////////////////////////////
'///////    查找
Private Sub CmdSearch_Click()
    '容错
    If Data1.Recordset.RecordCount = 0 Then
        MsgBox "无记录", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    End If
    
    '"查找内容"加入堆栈
    Dim equal As Boolean, i As Integer
    equal = False
    For i = 0 To n - 1
        If Combo.Text = Search(i) Then equal = True
    Next
    If Not equal Then
        ReDim Preserve Search(n)
        Combo.AddItem Combo.Text, n
        Search(n) = Combo.Text
        n = n + 1
    End If
    
    '查找
    With Data1.Recordset
        If Trim(Combo.Text) <> "" Then
            LastPosition = .Bookmark
            If CheckAllMatch.Value = 1 Then
                .FindFirst "[主题] like" & "'" & Trim(Combo.Text) & "'"
            Else
                .FindFirst "[主题] like" & "'*" & Trim(Combo.Text) & "*'"
            End If
            If .NoMatch Then
                MsgBox "数据库中不存在" & "主题为 '" & Trim(Combo.Text) & "' 的记录！"
                .Bookmark = LastPosition
                Exit Sub
            Else
                LastPosition = .Bookmark
                CmdSearch.Visible = False
                CmdSearchNext.Visible = True
            End If
        Else
            MsgBox "请输入要查找的主题！", vbExclamation
            Combo.SetFocus
        End If
    End With
End Sub

Private Sub CmdSearchNext_Click()
    '容错
    If Data1.Recordset.RecordCount = 0 Then
        MsgBox "无记录", vbInformation + vbOKOnly, "错误信息"
        Exit Sub
    End If
    
    '查找
    With Data1.Recordset
    If Trim(Combo.Text) <> "" Then
        LastPosition = .Bookmark
        If CheckAllMatch.Value = 1 Then
            .FindNext "[主题] like " & "'" & Trim(Combo.Text) & "'"
            Else
            .FindNext "[主题] like " & "'*" & Trim(Combo.Text) & "*'"
        End If
        If .NoMatch Then
            MsgBox "已搜索到数据库末了！"
            .Bookmark = LastPosition
            Exit Sub
        Else
            LastPosition = .Bookmark
        End If
    Else
        MsgBox "请输入要查找的主题！", vbExclamation
        Combo.SetFocus
    End If
    End With
End Sub

Private Sub Combo_Click()
    CmdSearch.Visible = True
    CmdSearchNext.Visible = False
End Sub

Private Sub Combo_Change()
    CmdSearch.Visible = True
    CmdSearchNext.Visible = False
End Sub