需要的引用：
下面的代码涉及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
交互表格如下：
