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 = "" ThenMsgBox "请输入用户ID！"Exit SubElse'查询tb用户表中Me.TxbUserID的数量，'如果有此用户，则计数结果应为1,否则为0SQL = "select count(*) from tb用户 where 用户ID='" & Me.TxbUserID & "'"arr = GetData(dataFile, SQL)If arr(0, 0) = 0 ThenMsgBox "无此用户ID！"Exit SubEnd IfEnd IfSQL = "select 密码,用户姓名 from tb用户 where 用户ID='" & Me.TxbUserID & "'"arr = GetData(dataFile, SQL)If arr(0, 0) = Me.TxtPassWord ThencurrUserID = Me.TxbUserIDcurrUserName = arr(1, 0)'把登录用户信息记到Sheets("Main")Sheets("Main").Range("A1") = "用户ID："Sheets("Main").Range("A2") = "用户姓名："Sheets("Main").Range("B1") = currUserIDSheets("Main").Range("B2") = currUserNameLoginStatus = 1Unload MeElseMsgBox "密码不正确，请重新输入！"Me.TxtPassWord = ""Me.TxtPassWord.SetFocusEnd 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

结果是这样子的：