池盛龙每日一分享：VBA连接数据库进行操作如何保证稳定又高效,试试我独创方法

池盛龙

全局声明变量

1. Option Explicit
   
2. Public cn As New ADODB.Connection
   
3. Public RS As New ADODB.Recordset
   
4. Public strSQL As String
   
5. Public ZdC As String
   
6. Public arr, brr

复制代码

数据库配置函数：我这里以MSSQL连接为示例

1. '功能描述： '配置数据库信息
   
2. '作者：池盛龙
   
3. '日期：2020-11-09
   
4. '个人网址：CHISHENGLONG.TOP
   
5. Public Function strCn()
   
6.   strSQLServer = "IP地址"
   
7.     strSQLUser = "账号"
   
8.     strSQLPW = "密码"
   
9.     strSQLDB = "数据库名"
   
10.     strCn = "Provider=sqloledb;Server=" & strSQLServer & ";Database=" & strSQLDB & ";Uid=" & strSQLUser & ";Pwd=" & strSQLPW
    
11. End Function

复制代码

查询函数

1. '功能描述： '用于执行SQL 插入、更新、修改、语句
   
2. '作者：池盛龙
   
3. '日期：2020-11-09
   
4. '个人网址：CHISHENGLONG.TOP
   
5. '调用方法如下：
   
6. 
   
7.   'If XSQL(CStr(SQL), True, [A5]) = False Then END
   
8.   '如果需要显示标题如下：
   
9. '    For X = 0 To UBound(brr, 2)
   
10. '        Cells(4, X + 1) = brr(0, X)
    
11. '    Next
    
12. 'If TypeName(arr) = "Nothing" Then MsgBox "暂无记录！", vbExclamation: Exit Sub
    
13. '获取结果继续赋值方法：
    
14. '  For X = 0 To UBound(arr, 2)
    
15. '        Cells(1 "B") = arr(ZSQL("订单编号"), X)
    
16. '        Cells(2 "C") = arr(ZSQL("物料名称"), X)
    
17. '        Cells(3, "D") = arr(ZSQL("规格"), X)
    
18. '        Cells(4 "E") = arr(ZSQL("单位"), X)
    
19. '        Cells(5, "F") = arr(ZSQL("数量"), X)
    
20. '        Cells(6, "G") = arr(ZSQL("单价"), X)
    
21. '    Next
    
22. 
    
23. '参数 [语句,是否需要,赋值位置]
    
24. Public Function XSQL(SQL As String, S As Boolean, dx As Object)
    
25.     XSQL = False
    
26.     ZdC = ""
    
27.     On Error GoTo ErrHandler
    
28.     cn.Open strCn
    
29.     Set RS = cn.Execute(SQL)
    
30.     ReDim brr(0, RS.Fields.Count - 1)
    
31.     Dim F As Integer     '获取标题
    
32.     For F = 0 To RS.Fields.Count - 1
    
33.         brr(0, F) = RS.Fields(F).Name
    
34.         ZdC = ZdC & "{" & F & "}" & RS.Fields(F).Name  '用于识别字段列的位置
    
35.     Next
    
36.     If RS.BOF = False Then    '有数据记录时执行
    
37.         arr = RS.GetRows    '获取结果且装置成二维数据
    
38.         If S = True Then
    
39.             ' CopyFromRecordset 或GetRows后，记录集指针已经移到了EOF，这时如果想继续使用该记录集，应该把其指针再移回第一条
    
40.             RS.MoveFirst    '指针移第一行 '
    
41.             dx.CopyFromRecordset RS
    
42.         End If
    
43.     Else
    
44.         Set arr = Nothing
    
45.     End If
    
46.     cn.Close    ' 关闭连接
    
47.     XSQL = True
    
48.     Exit Function
    
49. ErrHandler:
    
50.     If cn.State = adStateOpen Then cn.Close        '如果断开连接重新连接
    
51.     If Err.Number = -2147467259 Then
    
52.         MsgBox " 与数据库失去链接！无法获取数据", vbExclamation
    
53.     Else
    
54.         MsgBox " 系统错误 " & Err.Number & " ： " & Err.Description, vbExclamation
    
55.     End If
    
56. 
    
57. 
    
58.     Exit Function
    
59. End Function
    

复制代码

更新/修改/删除的函数

1. 更新、修改、删除函数
   
2. '功能描述： '用于执行SQL 插入、更新、修改、语句
   
3. '作者：池盛龙
   
4. '日期：2020-11-09
   
5. '个人网址：CHISHENGLONG.TOP
   
6. '调用方法如下：
   
7. 'If SSQL(CStr("DELETE FROM 表 ")) = False Then End
   
8. '参数 [插入、更新、修改、语句]
   
9. 
   
10. Public Function SSQL(SQL As String)
    
11.     SSQL = False
    
12.     On Error GoTo ErrHandler
    
13.     cn.Open strCn
    
14.     Set RS = cn.Execute(SQL)
    
15.     SSQL = True
    
16.     cn.Close
    
17.     Exit Function
    
18. ErrHandler:
    
19.     If cn.State = adStateOpen Then cn.Close        '如果断开连接重新连接
    
20.     If Err.Number = -2147467259 Then
    
21.         MsgBox " 与数据库失去链接！无法获取数据", vbExclamation
    
22.     Else
    
23.         MsgBox " 系统错误 " & Err.Number & " ： " & Err.Description, vbExclamation
    
24.     End If
    
25.     Exit Function
    
26. End Function

复制代码

使用效果：
查询操作：分2种，一种无结果赋值，一直有结果赋值{结果的意思是，不需要查询后把结果数据填到工作表}
图下方法为：无结果赋值

图下方法为：有结果赋值



更新/删除操作：

不明白使用的新手，可以留意下发提问。如果我的方法对你有帮助，麻烦你的小手送送小花，顶顶帖子。
我会定期发布帖子，想学更多技巧，继续关注

池盛龙

第一帖自己发射