VBA学习(71)：Excel VBA 访问带密码保护的Access数据库/用户窗体设置/EXCEL用户+密码登录界面（Access版）

前两天我们分享了一个用户密码登录EXCEL的案例【Excel VBA 用户窗体设置/一步一步代你设计EXCEL用户+密码登录界面】，文中提及数据存储在Access中的情况，今天我就来把数据表（tb用户）移到Access中，修改一下代码，登录界面保持不变。把EXCEL文件改名为“收费管理系统”并放到“收费管理系统”文件夹下。准备把前面分享的【中医诊所收费系统】重新来设计一下，并将设计过程分享给大家。 今天我们的任务是把“tb用户”表移到ACCESS数据库中，并实现正常登录。详细的窗体设计过程请看上期文章。

设计思路与过程：

1、新建一个Access数据库文件，这不是本文重点，具体过程也比较简单，我把它放在第二条文章。

2、在excel文件中，我们建立几个自定义函数，用来处理数据库连接，获取数据之用，我们可以参考复制前面的文件中的自定义函数​ （Excel VBA 凭证打印/SQL连接Eexcel文件/Listview控件/CommandButton命令按钮控件），稍作修改，把访问数据库的密码设置进去，具体如下：

Function GetExtn(iName)
    '获取文件后缀名
Function GetStrCnn(ByVal DbFile As String, Optional ByVal Psw As String = "")
'获取数据库连接字符串
Function GetData(dataFile, sql)
'获取SQL数据查询记录
    ......
    passWord = "p111111"
    strCnn = GetStrCnn(dataFile, passWord)
    ......
end sub
Function GetFields(dataFile, sql)
'获取SQL数据查询结果的字段名

3、设置一个公共变量dataFile，存放数据库文件的完整路径及文件名，并在Thisworkbook的open事件中，给它赋值：

Private Sub Workbook_Open()
    dataFile = "E:\我的坚果云QQ\我的坚果云\001-公众号\002-Excel活学活用\公众号示例文件\收费管理系统\收费管理系统数据库.accdb"
    UsF_Login.Show
End Sub

上面的代码还是有问题的，文件拷到别的电脑就不能正常运行了。我们可以改一下，采用相对路径，要求excel文件与Access文件放在同一个目录下，修改代码如下：

Private Sub Workbook_Open()
    dataFile = ThisWorkbook.Path & "\收费管理系统数据库.accdb"
    UsF_Login.Show
End Sub

这样，我们在EXCEL文件启动时，即取得数据文件路径，供后续访问，其他过程可以直接调用。不过，如果VBA代码运行异常退出，那么dafaFile的值可能会丢失，这样就无法重新登录，后续对数据库的操作也无法进行，只能关闭EXCEL文件再重新打开。这里为了方便起见，在“登录”按钮代码里还是重新对dataFile赋值，确保数据库连接正常。

4、修改Usf_Login用户窗体代码：

（1）Private Sub UserForm_Activate()

窗体激活代码，这里暂时可以什么都不用做，所以我把过程中的代码都给注释掉了，等后续再视情况添加代码。

（2）Private Sub CmdLogin_Click()，“登录”按钮点击事件：

Private Sub CmdLogin_Click()
    dataFile = ThisWorkbook.Path & "\收费管理系统数据库.accdb"
    '点击“登录”按钮
    '判断一下有没有输入用户ID，
    '如果为空，提示信息，然后退出
    If Me.TxbUserID = "" Then
        MsgBox "请输入用户ID！"
        Exit Sub
    Else
        '查询tb用户表中Me.TxbUserID的数量，
        '如果有此用户，则计数结果应为1,否则为0
        SQL = "select count(*) from tb用户 where 用户ID='" & Me.TxbUserID & "'"
        arr = GetData(dataFile, SQL)
        If arr(0, 0) = 0 Then
            MsgBox "无此用户ID！"
            Exit Sub
        End If
    End If
    SQL = "select 密码,用户姓名 from tb用户 where 用户ID='" & Me.TxbUserID & "'"
    arr = GetData(dataFile, SQL)
    If arr(0, 0) = Me.TxtPassWord Then
        currUserID = Me.TxbUserID
        currUserName = arr(1, 0)
        '把登录用户信息记到Sheets("Main")
        Sheets("Main").Range("A1") = "用户ID："
        Sheets("Main").Range("A2") = "用户姓名："
        Sheets("Main").Range("B1") = currUserID
        Sheets("Main").Range("B2") = currUserName
        LoginStatus = 1
        Unload Me
    Else
        MsgBox "密码不正确，请重新输入！"
        Me.TxtPassWord = ""
        Me.TxtPassWord.SetFocus
    End If
End Sub

代码解析：代码块中也有部分注释。

line 2: 给dataFile再次赋值，确保本过程接下来能正常读取数据库信息。

line 6~18：判断用户输入的“用户ID”，如果为空，则提示输入，否则就到数据库“tb用户”表中查询“用户ID=TxbUserID”的记录的数量，如果为0，则表明数据库中没有此用户ID，给出提示信息，退出过程，之所以要预先查询用户ID是否存在，是为了避免后面查询“密码、用户姓名”出现错误。

line 19：SQL语句，查询“用户ID=TxbUserID”的记录的“密码、用户姓名”。

line 20：查询结果存入数组。

line 21~35：比较查询到的密码【arr(0,0)】与用户输入的密码【TxtPassWord】，如果相同，则正常登录，退出窗体；如果不同，则提示密码不正确，返回继续输入。

这里注意一下，记录集对象的数据结构与我们正常看到的表格是不一样的。我们用代码测试下，输入到一个工作表“TEM”：

Sub test1()
    dataFile = ThisWorkbook.Path & "\收费管理系统数据库.accdb"
    SQL = "select * from tb用户"
    arr = GetFields(dataFile, SQL)
    arr = GetData(dataFile, SQL)
    Sheets("TEM").Range("A1").Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr
End Sub

结果是这样子的：   

我们可以把它作一个转置，但似乎也没有这个必要，记得它的结构就行了。

5、其他代码基本不用改，删除了EXCEL文件中的“tb用户”表，相关代码删除。

6、登录密码改为“123456”。看一下登录过程，与前面的并无两样。

 感谢你们的阅读和喜欢，我收藏了很多技术干货，可以共享给喜欢我文章的朋友们，如果你肯花时间沉下心去学习，它们一定能帮到你，干货内容：

点击文末的名片可以抱走，或点此链接