随笔- 7 文章- 3 评论- 1 阅读- 1858
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