excel使用VBA连接access
需要的引用：
下面的代码涉及excel对access数据库的增删改查，可以按照需要查找使用
1 '远程链接模块
2 Option Explicit
3 Dim con As New ADODB.Connection '创建连接对象
4 Dim rs As New ADODB.Recordset '声明记录集对象变量
5 Dim rsDS As New ADODB.Recordset '声明记录集对象变量
6 Dim rsPage As Integer '用于记录当前处于第几页
7 Dim mytable As String '当前表名称
8 Dim Opt() As Btns '定义类模块
9
10
11
12
13 Private Sub cmdBefore_Click()
14 If rsPage <> 1 Then
15 ListBox1.Clear
16 rsPage = rsPage - 1
17 Call AddRows(rsPage)
18 End If
19
20 End Sub
21
22 Private Sub cmdFirst_Click()
23 rsPage = 1
24 ListBox1.Clear
25 Call AddRows(rsPage)
26 End Sub
27
28 '添加数据
29 Private Sub CommandButton2_Click()
30 Dim i As Integer
31 Call ComboBox1_Change '刷新查询和显示
32
33 MsgBox ("请填写各项数据，除ID和add_time字段外均需要填写,填写完成后请点击保存按钮!")
34 CommandButton5.Visible = True
35 CommandButton2.Visible = False
36 End Sub
37
38
39 '修改记录
40 Private Sub CommandButton3_Click()
41 Dim sql As String
42 Dim i As Integer
43 Dim k As Integer
44 Dim savename As String
45
46 If MsgBox("本操作将更新编号为<" & Frame3.Controls.Item(1).Value _
47 & ">的记录，请确认详细数据中数值是否正确" & vbCrLf & "是否更新？", _
48 vbQuestion + vbYesNo, "更新记录") = vbNo Then Exit Sub
49 '如果待修改数据为空，退出修改
50 If Frame3.Controls.Item(1) = Empty Then
51 MsgBox ("请点击待修改数据！")
52 Exit Sub
53 End If
54 '确认修改权限
55 Dim rsuser As New ADODB.Recordset
56 sql = "SELECT " & mytable & ".user_name FROM " & mytable & " where ID=" & Frame3.Controls.Item(1)
57 rsuser.Open sql, con, adOpenKeyset, adLockOptimistic
58 If (rsuser.Fields(0).Value <> (Environ$("username") & "@" & Environ$("computername")) Or IsNull(rsuser.Fields(0).Value)) And Environ$("username") <> "xue-pc" Then
59 MsgBox ("该数据由" & rsuser.Fields(0).Value & "创建，请联系本人或管理员修改")
60 rsuser.Close
61 Exit Sub
62 End If
63 rsuser.Close
64
65 sql = ""
66 For i = 1 To Frame3.Controls.Count / 2 - 2
67 If i = Frame3.Controls.Count / 2 - 2 Then
68 sql = sql & Frame3.Controls.Item(2 * i).Caption & "='" & Frame3.Controls.Item(2 * i + 1) & "',user_name='" & Environ$("username") & "@" & Environ$("computername") & "'"
69 'bool类型进行区分赋值
70 ElseIf Frame3.Controls.Item(2 * i + 1).Name Like "mycheck*" Then
71 sql = sql & Frame3.Controls.Item(2 * i).Caption & "=" & Frame3.Controls.Item(2 * i + 1) & ","
72 ElseIf Frame3.Controls.Item(2 * i).Caption Like "image*" Then
73 '保存图片
74 sql = sql & Frame3.Controls.Item(2 * i).Caption & "='" & Frame3.Controls.Item(2 * i + 1) & "',"
75 savename = Frame3.Controls.Item(2 * i + 1).Value & "_" & Frame3.Controls.Item(9).Value & "_" & Frame3.Controls.Item(1).Value
76 k = saveimage(Frame3.Controls.Item(2 * i).Caption, savename)
77 Else
78 sql = sql & Frame3.Controls.Item(2 * i).Caption & "='" & Frame3.Controls.Item(2 * i + 1) & "',"
79 End If
80 Next i
81
82
83 sql = "update " & mytable & " set " & sql & " where ID=" & Frame3.Controls.Item(1).Value
84 'Debug.Print sql
85 con.Execute (sql)
86
87 MsgBox "已经成功将编号为<" & Frame3.Controls.Item(1).Value _
88 & ">的记录更新。", vbInformation, "更新记录"
89 '刷新查询和显示
90 Dim oldrspage As Integer '保存之前页面
91 oldrspage = rsPage
92 Call ComboBox1_Change '刷新查询和显示
93 ListBox1.Clear
94 Call AddRows(oldrspage) '显示当前页面
95 End Sub
96
97 '删除记录
98 Private Sub CommandButton4_Click()
99 On Error Resume Next
100 If Frame3.Controls.Item(1).Value = "" Then
101 MsgBox ("请在左侧列表中选择待删除数据")
102 Exit Sub
103 End If
104 Dim sql As String
105 '确定删除权限
106 Dim rsuser As New ADODB.Recordset
107 sql = "SELECT " & mytable & ".user_name FROM " & mytable & " where ID=" & Frame3.Controls.Item(1)
108 rsuser.Open sql, con, adOpenKeyset, adLockOptimistic
109 If (rsuser.Fields(0).Value <> (Environ$("username") & "@" & Environ$("computername")) Or IsNull(rsuser.Fields(0).Value)) And Environ$("username") <> "xue-pc" Then
110 MsgBox ("该数据由" & rsuser.Fields(0).Value & "创建，请联系本人或管理员删除")
111 rsuser.Close
112 Exit Sub
113 End If
114 rsuser.Close
115 sql = ""
116 If MsgBox("本操作将删除编号为<" & Frame3.Controls.Item(1).Value _
117 & ">的记录。" & vbCrLf & "是否要删除？", _
118 vbQuestion + vbYesNo, "删除记录") = vbNo Then Exit Sub
119 sql = "delete from " & mytable & " where ID=" & Frame3.Controls.Item(1).Value
120 Kill (DBIMGPATH & "*" & Frame3.Controls.Item(1) & ".bmp")
121
122 con.Execute (sql)
123 MsgBox "已经成功将编号为<" & Frame3.Controls.Item(1).Value _
124 & ">的记录删除。", vbInformation, "删除记录"
125 '刷新查询和显示
126 Dim oldrspage As Integer '保存之前页面
127 oldrspage = rsPage
128 Call ComboBox1_Change '刷新查询和显示
129 ListBox1.Clear
130 Call AddRows(oldrspage) '显示当前页面
131
132 End Sub
133 '保存记录
134 Private Sub CommandButton5_Click()
135 '判断是否输入数据
136
137 Dim i As Single
138 Dim imageflag As Integer '判断是否添加图片
139 Dim k As Integer
140 Dim savename As String
141 For i = 2 To rs.Fields.Count - 2
142 If Frame3.Controls.Item(2 * i - 1).Value = "" Then
143 MsgBox Frame3.Controls.Item(2 * i - 2).Caption & "数据为空,保存后可通过修改按钮进行编辑。", vbInformation
144 ElseIf Frame3.Controls.Item(2 * i - 2).Caption Like "image*" And Sheet5.Shapes.Count <> 0 Then
145 imageflag = MsgBox("确定添加sheet5中的图片到记录" & Frame3.Controls.Item(2 * i - 2).Caption & "中么？", vbYesNo + vbQuestion)
146 End If
147 Next i
148 If MsgBox("本操作将新增数据到数据库。" & vbCrLf & "是否添加？", vbQuestion + vbYesNo, "添加记录") = vbNo Then Exit Sub
149 '[开始添加数据
150
151 '其他数据添加
152 With rs
153 .AddNew
154 For i = 1 To rs.Fields.Count - 3
155 If .Fields(i).Name Like "Spectrum*" Then
156 .Fields(i) = fullspectrum(Frame3.Controls.Item(2 * i + 1).Value)
157 '图片数据添加
158 ElseIf .Fields(i).Name Like "image*" And imageflag = 6 Then
159 .Fields(i) = Frame3.Controls.Item(2 * i + 1).Value
160 '保存图片
161 savename = .Fields(i) & "_" & .Fields(4) & "_" & .Fields(0)
162 k = saveimage(.Fields(i).Name, savename)
163 Else
164 .Fields(i) = Frame3.Controls.Item(2 * i + 1).Value
165 End If
166
167 Next i
168 .Fields(rs.Fields.Count - 1) = Environ$("username") & "@" & Environ$("computername")
169 .Update
170 End With
171 MsgBox "添加数据成功。", vbInformation, "添加记录"
172
173
174 Call ComboBox1_Change '刷新查询和显示
175
176 Call AddRows(rs.PageCount) '显示当前页面
177 CommandButton5.Visible = False
178 CommandButton2.Visible = True
179
180
181 Exit Sub
182 Err_handle:
183 MsgBox Err.Description
184 End Sub
185
186
187 '导出所有数据
188 Private Sub CommandButton6_Click()
189 Sheet3.Cells.Clear
190 rs.MoveFirst
191 Dim i As Integer
192 For i = 0 To rs.Fields.Count - 2
193 Sheet3.Cells(1, i + 1) = rs.Fields(i).Name
194 Next i
195 Sheet3.Range("A2").CopyFromRecordset rs, , rs.Fields.Count - 1
196 Sheet3.Select
197
198 End Sub
199
200
201 Private Sub CommandButton7_Click()
202
203 End Sub
204
205
206
207 Private Sub Frame2_Click()
208
209 End Sub
210
211 Private Sub Frame3_Click()
212
213 End Sub
214
215 Private Sub Image1_Click()
216
217 End Sub
218
219 '将选择数据加载于文本框
220 Private Sub ListBox1_Click()
221 Dim i As Integer
222 Dim j As Integer
223 Dim clicknum As Integer '定义所点击的位置
224 clicknum = ListBox1.ListIndex
225 rsDS.MoveFirst
226 Dim imagenum As Integer
227 imagenum = 0
228 For i = 0 To rsDS.RecordCount - 1
229 If clicknum = i Then
230 For j = 0 To rsDS.Fields.Count - 2
231
232 DBconnection.Frame3.Controls.Item(2 * j + 1).Value = rsDS.Fields(j).Value
233 '修改image按钮caption
234 If rsDS.Fields(j).Name Like "image*" Then
235 Frame4.Controls.Item(imagenum).Caption = rsDS.Fields(j).Value & "_" & rsDS.Fields(4).Value & "_" & rsDS.Fields(0).Value
236 imagenum = imagenum + 1
237 End If
238
239
240 Next j
241 End If
242 rsDS.MoveNext
243
244 Next i
245
246 rsDS.MoveFirst
247
248
249
250
251 End Sub
252
253
254
255
256 Private Sub UserForm_Initialize()
257 '循环方式为组合框添加项目，提供显示条数的选择
258 Dim i As Integer '循环变量
259 For i = 1 To 20
260 cmbRecNum.AddItem i
261 Next
262 '链接数据库
263 con.Open "provider=microsoft.ace.oledb.12.0;data source=" & DBPATH & ";persist security info=false;jet oledb:database password='数据库密码'"
264 Set rs = con.OpenSchema(adSchemaTables)
265 ComboBox1.Clear
266 Do Until rs.EOF
267 If rs!table_type = "TABLE" And rs("table_name") <> "cal_need" Then '隐藏 cal_need 数据库
268 ComboBox1.AddItem (rs("table_name"))
269 End If
270 rs.MoveNext
271 Loop
272 rs.Close
273 '赋值初始数据
274 ComboBox1.ListIndex = 0
275 CommandButton5.Visible = False
276 CommandButton2.Visible = True
277
278 End Sub
279 '刷新DB输出的数据
280 Private Sub ComboBox1_Change()
281 '如果数据集开启则先关闭
282 CommandButton5.Visible = False '数据表变更后保存和新增按钮重置
283 CommandButton2.Visible = True '数据表变更后保存和新增按钮重置
284 If rs.State = 1 Then
285 rs.Close
286 End If
287 If rsDS.State = 1 Then
288 rsDS.Close
289 End If
290 Dim sql As String '定义SQL语句
291 Dim i As Integer '循环变量
292 Dim j As Integer '循环变量
293 Dim col As Integer '记录列数
294 mytable = ComboBox1.Value '赋值所选表数据
295 Dim myfield As ADODB.Field
296 Dim mytext As Control
297 sql = "select * from " & mytable & ";"
298 rs.Open sql, con, adOpenKeyset, adLockOptimistic
299 Dim rslist As New ADODB.Recordset '定义输入单元格list集合
300 Dim arr '定义list数组
301 Dim longtextnum As Integer '定义长文本个数,方便计算frame高度
302 Dim imagenum As Integer
303 imagenum = 0
304 longtextnum = 0
305 '添加表头数据
306 ListBox1.Clear
307 ListBox2.Clear
308 Frame3.Controls.Clear
309 Frame4.Controls.Clear
310 '当列数少时全部显示，大于mylistnum则显示mylistnum个列
311 mylistnum = 7 '默认列为7列
312 If rs.Fields.Count - 1 < mylistnum Then
313 mylistnum = rs.Fields.Count - 1 '
314 ListBox2.ColumnCount = rs.Fields.Count - 1
315 ListBox1.ColumnCount = rs.Fields.Count - 1
316 End If
317
318
319 With ListBox2
320 .Font.Name = "微软雅黑"
321 .AddItem
322 End With
323 For i = 0 To rs.Fields.Count - 2
324 If i < mylistnum + 1 Then
325 ListBox2.List(0, i) = rs.Fields(i).Name
326 End If
327
328 '增加详细数据的标签
329
330 Set mytext = DBconnection.Frame3.Controls.Add("Forms.Label.1", "mylabel" & i, True)
331 With mytext
332 .Caption = rs.Fields(i).Name
333 .Top = 10
334 .Left = 10
335 .Font.Name = "微软雅黑"
336 .Height = 30
337 If rs.Fields(i).Type = 203 Then
338 .Height = 100
339 longtextnum = longtextnum + 1
340 ElseIf rs.Fields(i).Type = 4 Or rs.Fields(i).Type = 11 Then '如果是数字格式，则给出提示，并使用蓝色字体
341 .ForeColor = RGB(0, 0, 255)
342 .Caption = rs.Fields(i).Name & Chr(13)
343 End If
344 If i > 0 Then
345 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
346 End If
347
348 End With
349
350
351
352 Select Case mytable '根据不同的table确定不同的输入框格式
353 Case "spectrum_lc"
354 '如果是短文本格式，使用复选框
355 If rs.Fields(i).Type = 202 Then
356 Set mytext = DBconnection.Frame3.Controls.Add("Forms.combobox.1", "mytext" & i, True)
357 sql = "SELECT DISTINCT " & mytable & "." & rs.Fields(i).Name & " FROM " & mytable
358 rslist.Open sql, con, adOpenKeyset, adLockOptimistic '打开数据集
359 ReDim arr(0 To rslist.RecordCount - 1) '重新定义数组大小
360 '赋值给Arr列表值
361 For j = 0 To rslist.RecordCount - 1
362 arr(j) = rslist.Fields(0)
363 rslist.MoveNext
364 Next j
365 rslist.Close
366 With mytext
367 .List = arr '赋值数组
368 .Top = 10
369 .Left = 80
370 .Width = 250
371 .Height = 30
372 .Font.Name = "微软雅黑"
373 ' If rs.Fields(i).Type = 203 Then
374 ' .Height = 100
375 ' End If
376 If i > 0 Then
377 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
378 End If
379 End With
380 Else
381 '如果是其他格式，添加文本框
382 Set mytext = DBconnection.Frame3.Controls.Add("Forms.textbox.1", "mytext" & i, True)
383 With mytext
384 .Top = 10
385 .Left = 80
386 .Width = 250
387 .MultiLine = True
388 .Height = 30
389 .Font.Name = "微软雅黑"
390 If rs.Fields(i).Type = 203 Then
391 .Height = 100
392
393 ElseIf rs.Fields(i).Type = 4 Then '如果是数字格式，则给出提示，并使用蓝色字体
394 .ForeColor = RGB(0, 0, 255)
395 .Value = "请输入数字格式，避免出错"
396 End If
397 If i > 0 Then
398
399 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
400 End If
401 End With
402 End If
403
404
405
406
407 Case "spectrum_blu"
408 '如果是短文本格式，使用复选框
409 If rs.Fields(i).Type = 202 Then
410 Set mytext = DBconnection.Frame3.Controls.Add("Forms.combobox.1", "mytext" & i, True)
411 sql = "SELECT DISTINCT " & mytable & "." & rs.Fields(i).Name & " FROM " & mytable
412 rslist.Open sql, con, adOpenKeyset, adLockOptimistic '打开数据集
413 ReDim arr(0 To rslist.RecordCount - 1) '重新定义数组大小
414 '赋值给Arr列表值
415 For j = 0 To rslist.RecordCount - 1
416 arr(j) = rslist.Fields(0)
417 rslist.MoveNext
418 Next j
419 rslist.Close
420 With mytext
421 .List = arr '赋值数组
422 .Top = 10
423 .Left = 80
424 .Width = 250
425 .Height = 30
426 .Font.Name = "微软雅黑"
427 If rs.Fields(i).Type = 203 Then
428 .Height = 100
429 End If
430 If i > 0 Then
431 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
432 End If
433 End With
434 Else
435 '如果是其他格式，添加文本框
436 Set mytext = DBconnection.Frame3.Controls.Add("Forms.textbox.1", "mytext" & i, True)
437 With mytext
438 .Top = 10
439 .Left = 80
440 .Width = 250
441 .MultiLine = True
442 .Height = 30
443 .Font.Name = "微软雅黑"
444 If rs.Fields(i).Type = 203 Then
445 .Height = 100
446 End If
447 If i > 0 Then
448
449 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
450 End If
451 End With
452 End If
453
454
455 Case "spectrum_pr"
456 '如果是短文本格式,且在第二个字段之后，使用复选框
457 If rs.Fields(i).Type = 202 And i > 1 Then
458 Set mytext = DBconnection.Frame3.Controls.Add("Forms.combobox.1", "mytext" & i, True)
459 sql = "SELECT DISTINCT " & mytable & "." & rs.Fields(i).Name & " FROM " & mytable
460 rslist.Open sql, con, adOpenKeyset, adLockOptimistic '打开数据集
461 ReDim arr(0 To rslist.RecordCount - 1) '重新定义数组大小
462 '赋值给Arr列表值
463 For j = 0 To rslist.RecordCount - 1
464 arr(j) = rslist.Fields(0)
465 rslist.MoveNext
466 Next j
467 rslist.Close
468 With mytext
469 .List = arr '赋值数组
470 .Top = 10
471 .Left = 80
472 .Width = 250
473 .Height = 30
474 .Font.Name = "微软雅黑"
475 If rs.Fields(i).Type = 203 Then
476 .Height = 100
477 End If
478 If i > 0 Then
479 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
480 End If
481 End With
482 Else
483 '如果是其他格式，添加文本框
484 Set mytext = DBconnection.Frame3.Controls.Add("Forms.textbox.1", "mytext" & i, True)
485 With mytext
486 .Top = 10
487 .Left = 80
488 .Width = 250
489 .Height = 30
490 .Font.Name = "微软雅黑"
491 If rs.Fields(i).Type = 203 Then
492 .Height = 100
493 .MultiLine = True
494 ElseIf rs.Fields(i).Type = 4 Then '如果是数字格式，则给出提示，并使用蓝色字体
495 .ForeColor = RGB(0, 0, 255)
496 .Value = "请输入数字格式，避免出错"
497 End If
498 If i > 0 Then
499
500 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
501 End If
502 End With
503 End If
504
505
506 Case "db_lc"
507 '如果是短文本格式,且在第二个字段之后，使用复选框
508 If rs.Fields(i).Type = 202 And i > 1 Then
509 Set mytext = DBconnection.Frame3.Controls.Add("Forms.combobox.1", "mytext" & i, True)
510 sql = "SELECT DISTINCT " & mytable & "." & rs.Fields(i).Name & " FROM " & mytable
511 rslist.Open sql, con, adOpenKeyset, adLockOptimistic '打开数据集
512 ReDim arr(0 To rslist.RecordCount - 1) '重新定义数组大小
513 '赋值给Arr列表值
514 For j = 0 To rslist.RecordCount - 1
515 arr(j) = rslist.Fields(0)
516 rslist.MoveNext
517 Next j
518 rslist.Close
519 With mytext
520 .List = arr '赋值数组
521 .Top = 10
522 .Left = 80
523 .Width = 250
524 .Height = 30
525 .Font.Name = "微软雅黑"
526 If rs.Fields(i).Type = 203 Then
527 .Height = 100
528 End If
529 If i > 0 Then
530 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
531 End If
532 End With
533 Else
534 '如果是其他格式，添加文本框
535 Set mytext = DBconnection.Frame3.Controls.Add("Forms.textbox.1", "mytext" & i, True)
536 With mytext
537 .Top = 10
538 .Left = 80
539 .Width = 250
540 .Height = 30
541 .Font.Name = "微软雅黑"
542 If rs.Fields(i).Type = 203 Then
543 .Height = 100
544 ElseIf rs.Fields(i).Type = 4 Then '如果是数字格式，则给出提示，并使用蓝色字体
545 .ForeColor = RGB(0, 0, 255)
546 .Value = "请输入数字格式，避免出错"
547 End If
548 If i > 0 Then
549
550 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
551 End If
552 End With
553 End If
554
555
556 Case "spectrum_backup"
557 '如果是短文本格式,且在第二个字段之后，使用复选框
558 If rs.Fields(i).Type = 202 Then
559 Set mytext = DBconnection.Frame3.Controls.Add("Forms.combobox.1", "mytext" & i, True)
560 sql = "SELECT DISTINCT " & mytable & "." & rs.Fields(i).Name & " FROM " & mytable
561 rslist.Open sql, con, adOpenKeyset, adLockOptimistic '打开数据集
562 ReDim arr(0 To rslist.RecordCount - 1) '重新定义数组大小
563 '赋值给Arr列表值
564 For j = 0 To rslist.RecordCount - 1
565 arr(j) = rslist.Fields(0)
566 rslist.MoveNext
567 Next j
568 rslist.Close
569 With mytext
570 .List = arr '赋值数组
571 .Top = 10
572 .Left = 80
573 .Width = 250
574 .Height = 30
575 .Font.Name = "微软雅黑"
576 If rs.Fields(i).Type = 203 Then
577 .Height = 100
578 End If
579 If i > 0 Then
580 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
581 End If
582 End With
583 Else
584 '如果是其他格式，添加文本框
585 Set mytext = DBconnection.Frame3.Controls.Add("Forms.textbox.1", "mytext" & i, True)
586 With mytext
587 .Top = 10
588 .Left = 80
589 .Width = 250
590 .MultiLine = True
591 .Height = 30
592 .Font.Name = "微软雅黑"
593 If rs.Fields(i).Type = 203 Then
594 .Height = 100
595 End If
596 If i > 0 Then
597
598 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
599 End If
600 End With
601 End If
602
603
604 Case "db_pi"
605 '如果是短文本格式,且在第二个字段之后，使用复选框
606 If rs.Fields(i).Type = 202 And i > 1 Then
607 Set mytext = DBconnection.Frame3.Controls.Add("Forms.combobox.1", "mytext" & i, True)
608 sql = "SELECT DISTINCT " & mytable & "." & rs.Fields(i).Name & " FROM " & mytable
609 rslist.Open sql, con, adOpenKeyset, adLockOptimistic '打开数据集
610 ReDim arr(0 To rslist.RecordCount - 1) '重新定义数组大小
611 '赋值给Arr列表值
612 For j = 0 To rslist.RecordCount - 1
613 arr(j) = rslist.Fields(0)
614 rslist.MoveNext
615 Next j
616 rslist.Close
617 With mytext
618 .List = arr '赋值数组
619 .Top = 10
620 .Left = 80
621 .Width = 250
622 .Height = 30
623 .Font.Name = "微软雅黑"
624 If rs.Fields(i).Type = 203 Then
625 .Height = 100
626 End If
627 If i > 0 Then
628 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
629 End If
630 End With
631 Else
632 '如果是其他格式，添加文本框
633 Set mytext = DBconnection.Frame3.Controls.Add("Forms.textbox.1", "mytext" & i, True)
634 With mytext
635 .Top = 10
636 .Left = 80
637 .Width = 250
638 .MultiLine = True
639 .Height = 30
640 .Font.Name = "微软雅黑"
641 If rs.Fields(i).Type = 203 Then
642 .Height = 100
643 ElseIf rs.Fields(i).Type = 4 Then '如果是数字格式，则给出提示，并使用蓝色字体
644 .ForeColor = RGB(0, 0, 255)
645 .Value = "请输入数字格式，避免出错"
646 End If
647 If i > 0 Then
648
649 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
650 End If
651 End With
652 End If
653
654
655
656 'lcd_ps 图片文件需要特殊设置
657 Case "lcd_ps"
658 '如果是短文本格式,且在第二个字段之后，使用复选框
659 If rs.Fields(i).Type = 202 And i > 1 Then
660 Set mytext = DBconnection.Frame3.Controls.Add("Forms.combobox.1", "mytext" & i, True)
661 sql = "SELECT DISTINCT " & mytable & "." & rs.Fields(i).Name & " FROM " & mytable
662 rslist.Open sql, con, adOpenKeyset, adLockOptimistic '打开数据集
663 ReDim arr(0 To rslist.RecordCount - 1) '重新定义数组大小
664 '赋值给Arr列表值
665 For j = 0 To rslist.RecordCount - 1
666 arr(j) = rslist.Fields(0)
667 rslist.MoveNext
668 Next j
669 rslist.Close
670 With mytext
671 .List = arr '赋值数组
672 .Top = 10
673 .Left = 80
674 .Width = 250
675 .Height = 30
676 .Font.Name = "微软雅黑"
677 If i > 0 Then
678 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
679 End If
680 End With
681 ' '如果是bool类型，则添加选项框
682 '
683 ElseIf rs.Fields(i).Type = 11 And i > 1 Then
684 Set mytext = DBconnection.Frame3.Controls.Add("Forms.CheckBox.1", "mycheck" & i, True)
685 With mytext
686 .Top = 10
687 .Left = 80
688 .Width = 250
689 .Height = 30
690 .Font.Name = "微软雅黑"
691 .Caption = "是否双段差"
692 If i > 0 Then
693 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
694 End If
695 End With
696 '如果是图片类型，在frame4中增加按钮选项
697 ElseIf rs.Fields(i).Name Like "image*" Then
698 'frame3的正常增加操作操作
699 Set mytext = DBconnection.Frame3.Controls.Add("Forms.textbox.1", "mytext" & i, True)
700 With mytext
701 .Top = 10
702 .Left = 80
703 .Width = 250
704 .MultiLine = True
705 .Height = 30
706 .Font.Name = "微软雅黑"
707 If rs.Fields(i).Type = 4 Then '如果是数字格式，则给出提示，并使用蓝色字体
708 .ForeColor = RGB(0, 0, 255)
709 .Value = "请输入数字格式，避免出错"
710
711 End If
712 If i > 0 Then
713
714 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
715 End If
716 End With
717
718 'frame4的增加按钮操作
719 Set mytext = DBconnection.Frame4.Controls.Add("Forms.CommandButton.1", "mybutton" & imagenum, True)
720 With mytext
721 .Top = imagenum * 29
722 .Left = 10
723 .Width = 80
724 .Font.Name = "微软雅黑"
725 .Caption = mytext.Name
726 End With
727 imagenum = imagenum + 1
728
729 '如果是其他格式，添加文本框
730 Else
731 Set mytext = DBconnection.Frame3.Controls.Add("Forms.textbox.1", "mytext" & i, True)
732 With mytext
733 .Top = 10
734 .Left = 80
735 .Width = 250
736 .MultiLine = True
737 .Height = 30
738 .Font.Name = "微软雅黑"
739 If rs.Fields(i).Type = 203 Then
740 .Height = 100
741 ElseIf rs.Fields(i).Type = 4 Then '如果是数字格式，则给出提示，并使用蓝色字体
742 .ForeColor = RGB(0, 0, 255)
743 .Value = "请输入数字格式，避免出错"
744
745 End If
746 If i > 0 Then
747
748 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
749 End If
750 End With
751 End If
752 '
753 Case Else
754 '如果是短文本格式,且在第二个字段之后，使用复选框
755 If rs.Fields(i).Type = 202 And i > 1 Then
756 Set mytext = DBconnection.Frame3.Controls.Add("Forms.combobox.1", "mytext" & i, True)
757 sql = "SELECT DISTINCT " & mytable & "." & rs.Fields(i).Name & " FROM " & mytable
758 rslist.Open sql, con, adOpenKeyset, adLockOptimistic '打开数据集
759 ReDim arr(0 To rslist.RecordCount - 1) '重新定义数组大小
760 '赋值给Arr列表值
761 For j = 0 To rslist.RecordCount - 1
762 arr(j) = rslist.Fields(0)
763 rslist.MoveNext
764 Next j
765 rslist.Close
766 With mytext
767 .List = arr '赋值数组
768 .Top = 10
769 .Left = 80
770 .Width = 250
771 .Height = 30
772 .Font.Name = "微软雅黑"
773 If i > 0 Then
774 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
775 End If
776 End With
777 '如果是bool类型，则添加选项框
778
779 ElseIf rs.Fields(i).Type = 11 And i > 1 Then
780 Set mytext = DBconnection.Frame3.Controls.Add("Forms.CheckBox.1", "mycheck" & i, True)
781 With mytext
782 .Top = 10
783 .Left = 80
784 .Width = 250
785 .Height = 30
786 .Font.Name = "微软雅黑"
787 .Caption = "是否双段差"
788 If i > 0 Then
789 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
790 End If
791 End With
792 Else
793 '如果是其他格式，添加文本框
794 Set mytext = DBconnection.Frame3.Controls.Add("Forms.textbox.1", "mytext" & i, True)
795 With mytext
796 .Top = 10
797 .Left = 80
798 .Width = 250
799 .MultiLine = True
800 .Height = 30
801 .Font.Name = "微软雅黑"
802 If rs.Fields(i).Type = 203 Then
803 .Height = 100
804 ElseIf rs.Fields(i).Type = 4 Then '如果是数字格式，则给出提示，并使用蓝色字体
805 .ForeColor = RGB(0, 0, 255)
806 .Value = "请输入数字格式，避免出错"
807
808 End If
809 If i > 0 Then
810
811 .Top = Frame3.Controls.Item(2 * i - 1).Top + Frame3.Controls.Item(2 * i - 1).Height + 10
812 End If
813 End With
814 End If
815 End Select
816
817
818 Next i
819 Frame3.ScrollHeight = 40 * (i - longtextnum) + 110 * longtextnum
820
821 '类模块设置
822 Dim cmdbtn As Object
823 Dim X As Integer
824 X = 0
825 For Each cmdbtn In Frame4.Controls
826 If TypeName(cmdbtn) = "CommandButton" Then
827 ReDim Preserve Opt(X)
828 Set Opt(X) = New Btns
829 Set Opt(X).ButtonObj = cmdbtn
830 X = X + 1
831 End If
832 Next cmdbtn
833
834
835
836
837 '设置不可编辑文本框的格式:ID文本框和时间文本框
838 With Frame3.Controls
839
840 .Item(1).Locked = True
841 .Item(1).ForeColor = RGB(255, 0, 0)
842 .Item(1).Font.Bold = True
843
844 .Item(2 * (rs.Fields.Count - 1) - 1).Locked = True
845 .Item(2 * (rs.Fields.Count - 1) - 1).ForeColor = RGB(255, 0, 0)
846 .Item(2 * (rs.Fields.Count - 1) - 1).Font.Bold = True
847 End With
848
849 '设置一些默认值，方便初始化区域
850 cmbRecNum.Value = 20 '默认每页显示20条记录
851 rsPage = 1 '默认显示第1页记录
852 Call AddRows(rsPage) '调用页面显示
853 End Sub
854
855 '自定义子过程，用于随时在lstShow控件上显示当前页的数据
856 Public Sub AddRows(mypage As Integer) 'myPage就表示第几页
857
858 Dim i As Integer, j As Integer
859 '创建局部RecordSet对象rsDS，保存rs记录集中当前页的记录数据
860 Set rsDS = New ADODB.Recordset '声明记录集对象变量
861 For i = 0 To rs.Fields.Count - 1
862 rsDS.Fields.Append rs.Fields(i).Name, rs.Fields(i).Type, rs.Fields(i).DefinedSize 'append 追加的意思
863 Next i
864 rsDS.Open '打开局部RecordSet对象rsDS
865 rs.PageSize = Val(cmbRecNum.Value) 'PageSize，表示记录集的每页的记录条数 重置rs每页显示的记录条数
866 rs.AbsolutePage = mypage '重置rs的当前记录页
867 '将rs当前记录页的记录保存到rsDS中
868 For i = 1 To rs.PageSize
869 rsDS.AddNew '添加一行记录
870 For j = 0 To rs.Fields.Count - 1
871 If rs.Fields(j).ActualSize = 0 Then
872 rsDS.Fields(j).Value = Empty
873 Else
874 rsDS.Fields(j).Value = rs.Fields(j).Value
875 End If
876 Next j
877 rs.MoveNext
878 If rs.EOF Then Exit For
879 Next i
880 '显示当前记录页
881 rsDS.MoveFirst '定位rsDS中的第一条记录
882 With ListBox1
883 .Font.Name = "微软雅黑"
884
885 For i = 1 To rsDS.RecordCount
886 .AddItem
887 For j = 0 To mylistnum
888 If rsDS.Fields(j).Type = 203 Then
889 .List(i - 1, j) = "--"
890 Else
891 .List(i - 1, j) = rsDS.Fields(j).Value
892 End If
893 Next j
894
895 rsDS.MoveNext
896 Next i
897 End With
898 txtPage.Value = mypage & "/" & rs.PageCount
899 End Sub
900
901 Private Sub cmdLast_Click()
902 ListBox1.Clear
903 rsPage = rs.PageCount
904 Call AddRows(rsPage)
905 End Sub
906
907 Private Sub cmdNext_Click()
908 If rsPage <> rs.PageCount Then
909 ListBox1.Clear
910 rsPage = rsPage + 1
911 Call AddRows(rsPage)
912 End If
913 End Sub
914
915 Private Sub cmbRecNum_Change()
916 rsPage = 1
917 ListBox1.Clear
918 Call AddRows(rsPage)
919 End Sub
920
921
922 Private Sub UserForm_Terminate()
923 If rs.State = 1 Then
924 rs.Close
925 End If
926 If rsDS.State = 1 Then
927 rsDS.Close
928 End If
929 Set rs = Nothing
930 Set rsDS = Nothing
931 Set con = Nothing
932 'Sheet3.Cells.Clear
933 End
934
935 End Sub
交互表格如下：
excel使用VBA连接access的更多相关文章
- Excel中VBA 连接 数据库 方法- 摘自网络
Sub GetData() Dim strConn As String, strSQL As String Dim conn As ADODB.Connection Dim ds As ADODB.R ...
- Excel中使用VBA访问Access数据库
VBA访问Access数据库 1. 通用自动化语言VBA VBA(Visual Basic For Application)是一种通用自动化语言,它可以使Excel中的常用操作自动化,还可以创建自定义 ...
- Excel VBA 连接各种数据库（二） VBA连接Oracle数据库
本文主要内容: Oracle环境配置 ODBC驱动设置.第三方驱动下载 VBA连接Oracle连接方法 Oracle10g官方免账号下载地址 系统环境: Windows 7 64bit Excel 2 ...
- Excel VBA 连接各种数据库（一） VBA连接MySQL数据库
本文参考[东围居士]的cnblog博文 Excel.VBA与MySQL交互 在自己机器上调试成功,把调试中遇到的问题一并写出了. 本文主要涉及: VBA中的MySQL环境配置 VBA连接MySQL ...
- Excel VBA连接MySql 数据库获取数据
编写Excel VBA工具,连接并操作Mysql 数据库. 系统环境: OS:Win7 64位 英文版 Office 2010 32位 英文版 1.VBA连接MySql前的准备 Tools---> ...
- Excel VBA 连接各种数据库（三） VBA连接SQL Server数据库
本文主要涉及: VBA中的SQL Server环境配置 VBA连接SQL Server数据库 VBA读写SQL Server数据 如何安装SQL Client 系统环境: Windows 7 64bi ...
- Access之C#连接Access
原文:Access之C#连接Access 如果是个人用的小程序的话.一般都推荐用Sqlite和Access 使用SQlite数据库需要安装SQLite驱动,详情:SQLite之C#连接SQLite 同 ...
- 64位sql server 如何使用链接服务器连接Access
原文:64位sql server 如何使用链接服务器连接Access 测试环境 操作系统版本:Windows Server 2008 r2 64位 数据库版本:Sql Server 2005 64位 ...
- Excel、VBA与MySQL交互
本文主要涉及: VBA中的MySQL环境配置 VBA连接MySQL数据库 VBA读写MySQL数据 在Excel中连接MySQL数据库及数据读写 系统环境: Windows 10 Excel 2013 ...
- 【.net 深呼吸】连接Access数据库应注意的几点
本地数据库可以有Y种选择,比如Sqlite.SQL Server Express.SQL Local DB.SQL Server CE.Access等,本文老周选用比较著名的Access本地数据库,在 ...
随机推荐
- Linux编译安装Canal
一.简介 下载源码:git clone https://github.com/alibaba/canal.git canal.adapter: 作用1:对接上游消息,包括kafka.rocketmq. ...
- Luogu P9180 [COCI2022-2023#5] Slastičarnica 题解 [ 蓝 ] [ 区间 dp ] [ dp 状态优化 ] [ 前缀和优化 ]
Slastičarnica:非常好的区间 dp 题. 暴力 不难设计出暴力状态:\(dp_{q,i,j}\) 表示进行到第 \(q\) 次操作,剩下区间 \([i,j]\) 是否可行. 直到全部状态都 ...
- 正则表达式匹配邮箱，IP地址，URL
参考链接: http://urlregex.com/ 1. 邮箱匹配正则表达式 C# ^(?(")(".+?(?<!\\)"@)|(([0-9a-z]((\.(?! ...
- ATT&CK实战系列（二）红日靶场2
拓扑图 导入虚拟机 网络配置 增加网卡 配置网卡 三台主机的密码均为1qaz@WSX,其中WEB在登录的时候需要切换用户de1ay登录 iP地址 DC PC 配置PC和WEB主机时,会弹框输入admi ...
- 最优化方法之AdaGrad、RMSProp、Adam
结论: 1.简单来讲,设置全局学习率之后,每次通过,全局学习率逐参数的除以历史梯度平方和的平方根,使得每个参数的学习率不同 2.效果是:在参数空间更为平缓的方向,会取得更大的进步(因为平缓,所以历史梯 ...
- bin格式转safetensors
技术背景 本文主要介绍在Hugging Face上把bin格式的模型文件转为safetensors格式的模型文件,并下载到本地的方法. bin转safetensors 首先安装safetensors: ...
- QT5笔记：5. QtCreator 的快捷键
常用的快捷键: F4 同名头文件和源文件之间切换 F2 声明和定义切换 Ctrl + / 注释 F10\F11 单步调试
- Forest v1.5.13 发布，声明式 HTTP 框架，已超 1.8k star
Forest介绍 Forest 是一个开源的 Java HTTP 客户端框架,它能够将 HTTP 的所有请求信息(包括 URL.Header 以及 Body 等信息)绑定到您自定义的 Interfac ...
- 李沐动手学深度学习V2-chapter_linear-networks
李沐动手学深度学习V2 文章内容说明 本文主要是自己学习过程中的随手笔记,需要自取 课程参考B站:https://space.bilibili.com/1567748478?spm_id_from=3 ...
- phpinclude-labs做题记录
Level 1 file协议 payload:?wrappers=/flag Level 2 data协议 去包含data协议中的内容其实相当于进行了一次远程包含,所以data协议的利用条件需要 ph ...