【VBA】Excel 密码管理器

完整实例已上传 Excel 密码管理器.xlsm

不想密码千篇一律，记性又太差，就做了这个。

更新日志

   日期       |         内容
------------ | ---------------------------------
2020-05-17   |  1、更改“只读”默认为“否”
	         |  2、提供消息提示，操作更直观
			 |  3、活动单元格离开本行，自动切换“只读” 
		  	 |  4、添加部分单元格注释

代码

ThisWorkbook

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.EnableEvents = False
    
    ' 清除日志
    Range("logs").Value = ""
    
    Application.EnableEvents = True
End Sub

Private Sub Workbook_Open()
    ' 工作簿打开事件

    '意思为 对菜单中 “工具-选项-安全性-保存时从文件属性中删除个人信息” 的取消勾选。
    ThisWorkbook.RemovePersonalInformation = False
    
    ' 禁用 Delete
    Application.OnKey "{DEL}", ""
    Application.OnKey "{DELETE}", ""
    
    ' 清除超链接
    Sheet1.Hyperlinks.Delete
    
    Sheet1.Cells(1, 1).Select
End Sub

Sheet1

Option Explicit

Public oldRow As Integer      ' 旧的行号，实现离开该行自动切换只读

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 离开本行自动切换为只读
    
    On Error GoTo e
    
    Application.EnableEvents = False
    
    Dim Row As Integer, Col As Integer
    
    Row = Target.Row
    Col = Target.Column
    
    'MsgBox "new:" & Row & "  old:" & oldRow
    If Col = 1 Or (Row <> oldRow And Target.Row > 4) Then
        If Range("K" & oldRow).Value = "False" Then
            Range("K" & oldRow).Value = "True"
        End If
    End If
    
    ' 刷新旧行
    oldRow = Row
    
    ' 清除日志
    Range("logs").Value = ""
    
    Application.EnableEvents = True
    
    Exit Sub
e:
    Select Case OnErrors
        Case 0
            Resume
        Case 1
            Resume Next
        Case 2
        
    End Select
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ' 单元格双击事件
    
    On Error GoTo e
    
    ' 关闭事件处理
    Application.EnableEvents = False
    
    Dim Row As Integer, Col As Integer, result As Integer, i As Integer, readNoly As Boolean
    
    ' 行号
    Row = Target.Row
    ' 列号
    Col = Target.Column
    
    Select Case Target.Name.Name
        ' 排除默认值区域
        Case "default_alias", "default_username", "default_phone_number", "default_mail", "default_first_name", "default_last_name"
            Application.EnableEvents = True
            Exit Sub
    End Select
    
    ' 是否只读
    If Range("K" & Row).Value = "False" Then
        readNoly = False
    Else
        readNoly = True
    End If

    If Row > 4 And (Col >= 2 And Col <= 9 And readNoly) And Cells(Row, Col) <> "" Then
        ' 只读时复制到剪切板
        Call copy_to_clipboard
    ElseIf Col >= 2 And Col <= 9 And Not readNoly Then
        ' 允许编辑单元格
        Application.EnableEvents = True
        Exit Sub
    ElseIf Col = 1 Then
        ' 以默认配置创建新行
        If Row = oldRow Then
            ' 切换只读
            If Range("K" & Row).Value = "False" Then
                Range("K" & Row).Value = "True"
            End If
        End If
        For i = 5 To 180
            If Range("A" & i).Value = "" Then
                create_new_row (i)
                Exit For
            End If
        Next
    ElseIf Col = 11 Then
        ' 切换只读状态
        If Target.Value = "True" Then
            result = MsgBox("确定取消“只读”吗？", vbOKCancel + vbQuestion, "来自 one-ccs 的提示")
            If result = vbOK Then
                Target.Value = "False"
            End If
        ElseIf Target.Value = "False" Then
            Target.Value = "True"
        End If
    ElseIf Col = 12 And Row > 4 And Cells(Row, Col - 1) <> "" Then
        ' 清空行
        result = MsgBox("确定“清空”本行吗？该操作无法恢复！！", vbOKCancel + vbExclamation, "来自 one-ccs 的警告")
        If result = vbOK Then
            ' Application.EnableEvents = False
            Range("A" & Row & ":L" & Row).ClearContents
            Range("logs").Value = "[ " & Now() & " ] 清空行（" & Row & "）"
            ' Application.EnableEvents = True
        End If
    End If
    
    ' 开启事件处理
    Application.EnableEvents = True
    
    ' Cancel 值为 True 时表示事件已被处理，将不再交换给系统（双击事件是进入编辑模式）
    ' 所有事件的Cancel参数,都用来取消该事件的下一步执行,就BeforeDoubleClick事件来说,正常情况下,将使Target 单元格进入编辑状态,如果在事件中指定Cancel参数为True,将禁止单元格进入编辑状态.
    Cancel = True
    
    Exit Sub
e:
    Select Case OnErrors
        Case 0
            Resume
        Case 1
            Resume Next
        Case 2
        
    End Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 实现只读效果
    
    On Error GoTo e
    
    Application.EnableEvents = False
    
    Dim Row As Integer, Col As Integer, result As Integer, readNoly As Boolean
    
    ' 行号
    Row = Target.Row
    ' 列号
    Col = Target.Column
    
    ' 是否只读
    If Range("K" & Row).Value = "False" Then
        readNoly = False
    Else
        readNoly = True
    End If
    
    Select Case Target.Name.Name
        ' 排除默认值区域
        Case "default_alias", "default_username", "default_phone_number", "default_mail", "default_first_name", "default_last_name"
            Application.EnableEvents = True
            Exit Sub
    End Select
    
    If Row <= 4 Or Col > 9 Or (Col >= 1 And Col <= 12 And readNoly) Then
        result = MsgBox("该单元格不可编辑!", vbOKOnly + vbExclamation, "来自 one-ccs 的警告")
        Application.Undo
    End If
    
    Application.EnableEvents = True
    Exit Sub
e:
    Select Case OnErrors
        Case 0
            Resume
        Case 1
            Resume Next
        Case 2
        
    End Select
End Sub

Private Function create_new_row(ByVal Row As Integer)
    ' 在行号 Row 生成默认配置
    
    On Error GoTo e
    
    Range("A" & Row).Value = Row - 4
    Range("B" & Row).Value = "*"
    Range("C" & Row).Value = Range("default_alias").Value
    Range("D" & Row).Value = Range("default_username").Value
    Range("E" & Row).Value = get_password()
    Range("F" & Row).Value = Range("default_phone_number").Value
    Range("G" & Row).Value = Range("default_mail").Value
    Range("H" & Row).Value = Range("default_first_name").Value
    Range("I" & Row).Value = Range("default_last_name").Value
    Range("J" & Row).Value = Now()
    Range("K" & Row).Value = "False"
    Range("L" & Row).Value = "X"
    
    oldRow = Row
    Cells(Row, 1).Select
    
    Exit Function
e:
    Select Case OnErrors
        Case 0
            Resume
        Case 1
            Resume Next
        Case 2
        
    End Select
End Function

Private Function copy_to_clipboard()
    ' 复制到剪切板
    
    Dim str As String
    
    str = ActiveCell.Value
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText str
        .PutInClipboard
    End With
    
    Range("logs").Value = "[ " & Now() & " ] 复制成功（" & str & "）"
    
End Function

Private Function get_password() As String
    Dim password As String
    
    password = Chr(Int(Rnd() * 26 + 65)) & _
               Int(Rnd() * 9 + 1) & _
               Chr(Int(Application.RandBetween(33, 47))) & _
               Chr(Int(Rnd() * 26 + 65)) & _
               Chr(Int(Rnd() * 26 + 65)) & _
               Int(Rnd() * 9 + 1) & _
               Chr(Int(Application.RandBetween(33, 47))) & _
               Chr(Int(Rnd() * 26 + 97)) & _
               Int(Rnd() * 900 + 100) & _
               Chr(Int(Rnd() * 26 + 97)) & _
               Int(Rnd() * 9 + 1) & _
               Chr(Int(Application.RandBetween(33, 47))) & _
               Chr(Int(Rnd() * 26 + 65))
    
    get_password = password
End Function

Private Function OnErrors() As Integer
    ' 错误处理函数
    
    Dim info As String
    
    info = "[ " & Now() & " ] 程序遇到错误！" & _
           "错误码：" & err.Number & _
           "；错误信息：" & err.Description
    
    Select Case err.Number
        Case -2147221040
            OnErrors = 1
        Case 438
            OnErrors = 1
        Case 1004
            ' Range("logs").Value = info
            OnErrors = 1
        Case Else
            Range("logs").Value = info & "处理方式：跳过错误"
            ' 跳过错误继续执行
            OnErrors = 1
    End Select
End Function