Access开发:VBA一键实现给Access文件加密

Hi，大家好！

又到了每周的分享时间。最近有粉丝提醒我，有人把我免费发布的内容打包成付费产品出售。为了避免大家走弯路，记得关注正版账号，第一时间获取最新的 Access 技巧。

本周一直在选题，恰好有朋友提到数据库安全，那今天给大家讲讲给access设置密码的功能吧。

我们给access文件加密的话，一般都是手工操作吧，这个大家都会，但老粉都知道，我分享功能，从来都是不讲手工操作的，老规矩，我们来动手写代码，作为一名 Access 开发者，不妨把这段代码塞进你的工具箱，下次交付时多一份专业，也多一份安全。

01

创建窗体

第一步，我们还先来创建一个窗体，在窗体上放三个文本框，两个按钮，具体的如图，

注意哦，两个输入密码的文本框，要设置一下输入掩码的格式为密码。

02

添加代码

接着，我们就可以来添加代码了，先在浏览按钮的单击事件里添加代码，具体代码如下：

Private Sub btnbrowse_Click()
        With FileDialog(3)
        .Filters.Clear
        .Title = "请先选择数据库"
        .InitialFileName = ""
        .Filters.Add "Access", "*.mdb;*.accdb"
        If .Show Then
            Me.txtPath = .SelectedItems(1)
        End If
    End With
End Sub

接着，添加加密按钮的单击事件，代码里都添加注释了，有不懂的地方，大家可以看一下注释。其实注释是让AI帮我写的（手动狗头保命），嘿嘿！！！

Private Sub btnOK_Click()
    On Error GoTo EH
    
    Dim eng      As DAO.DBEngine
    Dim srcPath  As String        '原库
    Dim tmpPath  As String        '临时库
    Dim pwd      As String        '新密码
    
    srcPath = Trim(Me.txtPath)
    pwd = Trim(Me.txtPWD)
    
    '密码一致性校验
    If pwd <> Trim(Me.txtPWD2) Then
        MsgBox "两次输入的密码不相同，请重新输入。", vbExclamation, "提示"
        Exit Sub
    End If
    
    '源文件是否存在
    If Len(Dir(srcPath)) = 0 Then
        MsgBox "未找到源数据库文件！", vbExclamation, "提示"
        Exit Sub
    End If
    
    '生成临时文件名：原文件后缀 .tmp 便于回滚
    tmpPath = srcPath & ".tmp"
    
    '备份原库到临时文件
    Name srcPath As tmpPath
    
    'Compact 并加密
    Set eng = New DAO.DBEngine
    eng.CompactDatabase tmpPath, srcPath, , , ";pwd=" & pwd
    
    ' 删除备份
    Kill tmpPath
    
    MsgBox "加密成功！", vbInformation, "提示"
    Exit Sub
    
EH:
    MsgBox "加密失败：" & Err.Description, vbCritical, "错误"
    
    '发生异常则回滚
    If Len(Dir(tmpPath)) > 0 Then
        If Len(Dir(srcPath)) > 0 Then Kill srcPath
        Name tmpPath As srcPath
    End If
End Sub

03

测试

最后，就是测试了，测试前，可以先新建一个access文件，选择文件后，输入具体的密码就可以了，像我这样：

密码设置好了，再打开access文件，就会要求你输入密码了，如图：

好了，大家赶紧去试一下吧，原创不易，大家给个一键三连吧！