本文于2023年5月13日首发于本人同名公众号：Excel活学活用，更多文章敬请关注！

☆本期内容概要☆

• EXCEL VBA连接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 EndSub

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

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

这样，我们在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 EndSub

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

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 EndSub

结果是这样子的：

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

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

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

好，今天就分享到这，请大家点赞、留言、分享，谢谢大家，我们下期再会。

☆猜你喜欢☆

本文于2023年5月13日首发于本人同名公众号：Excel活学活用，更多文章敬请关注！