VB实现SQL数据库记录的查询，新增，删除，修改，保存

1983leon

求高手写个简单的例子，谢谢！

QQ214189912

。。，。。。。

1983leon

QQ214189912 发表于 2014-11-29 10:54
。。，。。。。

系统错误&H8004011（-2147221231). classfactory 无法供应请求的类别                          内存溢出  


提示错误啊 大侠！

opiona

1. Sub opiona()
   
2. Rem Excel链接本地数据库SQL Server
   
3.     'Data Source=服务器名称
   
4.     'Initial Catalog=数据库名称
   
5.     'Uid=SA 用户名
   
6.     'PWD=1002 '/密码
   
7.     Str_coon = "Provider=SQLOLEDB.1;Data Source=FANGWEI;Initial Catalog=CPECC_Temp;Uid=SA;PWD=1002;Persist Security Info=false"
   
8.     StrSQL = "SELECT * FROM 用户信息表格"
   
9.     ARR = GET_SQLCoon(StrSQL, Str_coon, True)
   
10.     Sheet1.Range("A1").Resize(UBound(ARR, 1) + 1, UBound(ARR, 2) + 1) = ARR
    
11.    
    
12. End Sub
    
13. 
    
14. 
    
15. 
    
16. 'CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName    '//连接Excel2007
    
17. 'CN.Open "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';data source=" & ThisWorkbook.FullName      '//OFFICE2003
    
18. 'CN.Open "provider=Microsoft.JET.OLEDB.4.0;data source=" & ThisWorkbook.Path & "\Info.mdb"
    
19. 'CN.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & ThisWorkbook.Path & "\DB.mdb;Jet OLEDB:Database Password=52330067"                                                                 '//连接Access
    
20. 'CN.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\数据库名.accdb;Jet OLEDB:Database Password=52330067"                                               '//连接Access2007-2010
    
21. 'CN.Open "Provider=SQLOLEDB;Server=192.168.0.2;Database=元器件信息查询;Uid=sa;Pwd=1001;"                                    '//SQLServer 局域网内链接
    
22. 'CN.Open "provider = OraOLEDB.oracle; Data Source = suntime; User ID =用户名; Password =密码;"                                     '//Oracle
    
23. 'CN.Open "Provider=SQLOLEDB;User ID=sa;Password =1001;Data Source=FANGWEI\SQL2005数据"                                       '//SQLServer 本地链接
    
24. 'CN.Open "Provider=SQLOLEDB.1;Data Source=FANGWEI;Initial Catalog=CPECC_Temp;Uid=SA;PWD=1002;Persist Security Info=false"       '//SQLServer 2008本地链接
    
25.    'Data Source=服务器名称
    
26.    'Initial Catalog=数据库名称
    
27.    'Uid=SA 用户名
    
28.    'PWD=1002 '/密码
    
29. '*****************************************************************************************
    
30. '函数名：    GET_SQLCoon
    
31. '函数功能：  获得指定SQL的查询结果，自定义连接字符串，可以连接各种数据库
    
32. '返回值：    返回一个二维数组
    
33. '参数1：     StrSQL   字符类型   SQL查询语句
    
34. '参数2：     Str_coon 字符类型   数据库连接语句
    
35. '参数3：     Biaoti   可参数选   是否输出标题，默认带有标题
    
36. '使用方法：  Arr =  GET_SQLCoon(StrSQL,Str_coon,true)
    
37. '            Arr(0,1)  '//数组第一行为标题行，从i=1 开始是数据
    
38. '            Sh2.Range("A2").Resize(UBound(ARR, 1) + 1, UBound(ARR, 2) + 1) = ARR
    
39. '*****************************************************************************************
    
40. Public Function GET_SQLCoon(ByVal StrSQL As String, ByVal Str_coon As String, Optional Biaoti As Boolean = True) As Variant()
    
41. On Error Resume Next    ' 改变错误处理的方式。
    
42. Dim CN, RS
    
43.    Err.Clear
    
44.    Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
    
45.    Set RS = CreateObject("adodb.recordset")
    
46.        CN.Open Str_coon
    
47.        RS.Open StrSQL, CN, 1, 3
    
48. '       If RS.RecordCount > 0 Then '//如果找到数据
    
49.             If Biaoti = True Then
    
50.                  ReDim ARR(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
    
51.                      For a = 0 To RS.Fields.Count - 1  '//导入标题
    
52.                         ARR(0, a) = RS.Fields(a).Name
    
53.                      Next
    
54.                  For i = 0 To RS.RecordCount - 1  '//导入数据
    
55.                      For a = 0 To RS.Fields.Count - 1
    
56.                          ARR(i + 1, a) = RS.Fields(a).Value
    
57.                      Next a
    
58.                      RS.MoveNext
    
59.                  Next
    
60.             Else
    
61.                  ReDim ARR(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
    
62.                  For i = 0 To RS.RecordCount - 1  '//导入数据
    
63.                      For a = 0 To RS.Fields.Count - 1
    
64.                          ARR(i, a) = RS.Fields(a).Value
    
65.                      Next a
    
66.                      RS.MoveNext
    
67.                  Next
    
68.             End If
    
69. '        Else '//如果没有找到数据
    
70. '            ReDim Arr(1, 1)
    
71. '            Arr(0, 0) = ""
    
72. '        End If
    
73. 
    
74.   GET_SQLCoon = ARR
    
75.   CN.Close  '//关闭ADO连接
    
76.   Set RS = Nothing
    
77.   Set CN = Nothing  '//释放内存
    
78. End Function
    
79. 
    
80. '*****************************************************************************************
    
81. '函数名：    GET_SQLRS
    
82. '函数功能：  获得指定SQL的查询结果，修改CN连接字符串，可以连接各种数据库
    
83. '返回值：    返回一个recordset数据集
    
84. '参数1：     StrSQL   字符类型   SQL查询语句
    
85. '使用方法： Set RS = CreateObject("adodb.recordset")  '//先引用ADO：Microsoft ActiveX Data Objects 2.5 或更高版本
    
86.             'Set RS = GET_SQLRS(StrSQL,StrCoon)
    
87.             'Sh1.Range("A2").CopyFromRecordset RS
    
88. '*****************************************************************************************
    
89. Public Function GET_SQLRS(ByVal StrSQL As String, ByVal Str_coon As String) As ADODB.Recordset
    
90. On Error Resume Next    ' 改变错误处理的方式。
    
91. Dim CN, RS
    
92.     Err.Clear
    
93.     Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
    
94.     Set RS = CreateObject("adodb.recordset")
    
95.     CN.Open Str_coon
    
96.     RS.Open StrSQL, CN, 1, 3
    
97.     Set GET_SQLRS = RS
    
98. GET_SQLRS_Exit:
    
99.     Exit Function
    
100. GET_SQLRS_Error:
     
101.     MsgBox Err.Description
     
102.     Resume GET_SQLRS_Exit
     
103. End Function
     
104. '*****************************************************************************************
     
105. '函数名：    GET_SQL
     
106. '函数功能：  获得指定SQL的查询结果，修改CN连接字符串，可以连接各种数据库
     
107. '返回值：    返回一个二维数组
     
108. '参数1：     StrSQL   字符类型   SQL查询语句
     
109. '参数2：     Biaoti   可参数选   是否输出标题，默认带有标题
     
110. '使用方法：  Arr = GET_SQL(StrSQL,true)
     
111. '            Arr(0,1)  '//数组第一行为标题行，从i=1 开始是数据
     
112. '            Sh2.Range(Sh2.Cells(1, 1).Address, Sh2.Cells(UBound(Arr, 1) + 1, UBound(Arr, 2) + 1).Address) = Arr
     
113. '*****************************************************************************************
     
114. Public Function GET_SQL(StrSQL As String, Optional Biaoti As Boolean = True) As Variant()
     
115. On Error Resume Next    ' 改变错误处理的方式。
     
116. Dim CN, RS
     
117.    Err.Clear
     
118.    Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
     
119.    Set RS = CreateObject("adodb.recordset")
     
120.        CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
     
121.        RS.Open StrSQL, CN, 1, 3
     
122.        If Biaoti = True Then
     
123.             ReDim ARR(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
     
124.                 For a = 0 To RS.Fields.Count - 1  '//导入标题
     
125.                    ARR(0, a) = RS.Fields(a).Name
     
126.                 Next
     
127.             For i = 0 To RS.RecordCount - 1  '//导入数据
     
128.                 For a = 0 To RS.Fields.Count - 1
     
129.                     ARR(i + 1, a) = RS.Fields(a).Value
     
130.                 Next a
     
131.                 RS.MoveNext
     
132.             Next
     
133.        Else
     
134.             ReDim ARR(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
     
135.             For i = 0 To RS.RecordCount - 1  '//导入数据
     
136.                 For a = 0 To RS.Fields.Count - 1
     
137.                     ARR(i, a) = RS.Fields(a).Value
     
138.                 Next a
     
139.                 RS.MoveNext
     
140.             Next
     
141.        End If
     
142.   GET_SQL = ARR
     
143.   CN.Close  '//关闭ADO连接
     
144.   Set RS = Nothing
     
145.   Set CN = Nothing  '//释放内存
     
146. End Function
     
147. ''*****************************************************************************************
     
148. '函数名：    NumInfoSql
     
149. '函数功能：  获得指定SQL的查询结果的行数，修改CN连接字符串，可以连接各种数据库
     
150. '返回值：    返回一个整数
     
151. '参数1：     StrSQL   字符类型   SQL查询语句
     
152. '使用方法：  Int= NumInfoSql(StrSQL,true)
     
153. '*****************************************************************************************
     
154. 
     
155. Public Function NumInfoSql(ByVal StrSQL As String, ByVal Str_coon As String) As Integer      '//执行SQL语句查到数据个数
     
156. On Error Resume Next    ' 改变错误处理的方式。
     
157. Dim CN, RS
     
158.    Err.Clear
     
159.    If StrSQL = "" Then NumInfoSql = 0: Exit Function
     
160.    Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
     
161.    Set RS = CreateObject("adodb.recordset")
     
162.        CN.Open Str_coon
     
163.        RS.Open StrSQL, CN, 1, 3
     
164.        If Err.Number <> 0 Then NumInfoSql = 0 Else NumInfoSql = RS.RecordCount
     
165.   CN.Close  '//关闭ADO连接
     
166.   Set RS = Nothing
     
167.   Set CN = Nothing  '//释放内存
     
168. End Function
     
169. 
     
170. '*****************************************************************************************
     
171. '函数名：    AddDelMove
     
172. '函数功能：  执行SQL语句，一般为添加、修改删除语句
     
173. '返回值：    返回一个布尔值，是否成功完成
     
174. '参数1：     StrSQL     字符类型   SQL查询语句
     
175. '参数2：     Str_coon   字符类型   链接语句
     
176. '使用方法： StrSQL=“update [sheet1$i8:i9] set f1='Your Pleasure”
     
177. '                     StrSQL="insert into [sheet1$k2:l6] (f1,f2) values (9,'mine')"
     
178. '                     Bool_1= AddDelMove(StrSQL, Str_coon)
     
179. '*****************************************************************************************
     
180. Public Function AddDelMove(ByVal StrSQL As String, ByVal Str_coon As String) As Boolean    '//执行SQL语句，一般为添加、修改删除语句
     
181. On Error Resume Next    ' 改变错误处理的方式。
     
182. Err.Clear
     
183.     If StrSQL = "" Then AddDelMove = False: Exit Function
     
184.         Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
     
185.         Set RS = CreateObject("adodb.recordset")
     
186.         CN.Open Str_coon
     
187.         CN.Execute (StrSQL)
     
188.         If Err.Number <> 0 Then AddDelMove = False Else AddDelMove = True
     
189.         CN.Close  '//关闭ADO连接
     
190.     Set RS = Nothing
     
191.     Set CN = Nothing  '//释放内存
     
192. End Function
     
193. '*****************************************************************************************
     

复制代码

29151429

mk                                             

QQ214189912

估计引用问题吧 我的是office2010 运行没问题

wsjianfeng

厉害了，学习中

cnlo

QQ214189912 发表于 2014-11-29 10:54
。。，。。。。

修改了下你这个文件，同时加上了大量数据，在listview的双击修改环节出了问题，不会改那些代码，还有是导出的时候，如果已交费的达到9W多条的情况下，读取导出的数量金额都有问题。导出excel身份证号码也会被常规格式截断。大神能完善不？

1588078/37

cnlo 发表于 2019-8-9 23:38
修改了下你这个文件，同时加上了大量数据，在listview的双击修改环节出了问题，不会改那些代码，还有是导 ...

上我的共享文件看，有专门VBA操作SQL数据库的

candysea2006

1588078/37 发表于 2019-8-10 14:16
上我的共享文件看，有专门VBA操作SQL数据库的

您的共享文件在哪里查看呀？