excel vba常用实例

Option Explicit'一、窗体相关代码'1.加载窗体时，建立数据库连接，并刷新'数据库'列表框的信息Private Sub UserForm_Initialize() '1.建立数据库的连接 Call 数据库连接 '2.调用自定义过程，为'数据库表清单'列表框刷新数据 Call 获取数据表清单 End Sub'2.过程1：获取数据表清单，用于列表框刷新数据Public Sub 获取数据表清单() Set rs = cnn.OpenSchema(adSchemaTables) '获取数据表的所有表名到记录集中 With 数据表清单 '数据表清单为'数据表’列表框 .Clear Do Until rs.EOF '循环记录集的所有记录，找出表名称 If rs!table_type = 'TABLE' Then .AddItem rs!table_name '将满足条件的表名称添加到列表中 End If rs.MoveNext Loop .ListStyle = fmListStyleOption '设置每个选项有单选按钮 End With rs.Close Set rs = Nothing End Sub'3.过程2：获取字段清单，并显示在'字段’列表框中Public Sub 获取字段清单() Dim sql As String, i As Integer Set rs = New ADODB.Recordset '查询数据表，将字段名清单设置给'字段'列表框 sql = 'select * from ' & 数据表清单.Text '选中对象的文本 Set rs = New ADODB.Recordset rs.Open sql, cnn, adOpenKeyset, adLockOptimistic With 字段清单 .Clear For i = 0 To rs.Fields.Count - 1 .AddItem rs.Fields(i).name Next .ListStyle = fmListStyleOption End With rs.Close Set rs = Nothing End Sub'4.过程3：获取字段信息，并显示文本中Public Sub 获取字段信息() Dim sql As String, i As Integer '查询选中的数据表 sql = 'select * from ' & 数据表清单.Text Set rs = New ADODB.Recordset rs.Open sql, cnn, adOpenKeyset, adLockOptimistic '将字段的名称，类型，大小输出到对应的文本框中 字段名称.Value = rs.Fields(字段清单.Text).name '字段名称 字段类型.Value = IntToString(rs.Fields(字段清单.Text).Type) '通过自定义函数获取字段类型名称 字段大小.Value = rs.Fields(字段清单.Text).DefinedSize '字段大小 rs.Close Set rs = NothingEnd Sub'5.自定义函数，用于将数据类型整数值转换为类型字符串Function IntToString(MyInt As Integer) As String Dim MyStr As String '定义类型字符串变量，用于存储转换后的类型字符串 ' 未更改完，感觉没什么卵用，而且抄起来很烦 Select Case MyInt Case 20: MyStr = 'adBigInt' Case 128: MyStr = 'adBigInt' Case 11: MyStr = 'adBigInt' Case 8: MyStr = 'adBigInt' Case 136: MyStr = 'adBigInt' Case 129: MyStr = 'adBigInt' Case 6: MyStr = 'adBigInt' Case 7: MyStr = 'adBigInt' Case 133: MyStr = 'adBigInt' Case 134: MyStr = 'adBigInt' Case 135: MyStr = 'adBigInt' Case 14: MyStr = 'adBigInt' Case 5: MyStr = 'adBigInt' Case 0: MyStr = 'adBigInt' Case 10: MyStr = 'adBigInt' Case 64: MyStr = 'adBigInt' Case 72: MyStr = 'adBigInt' Case 9: MyStr = 'adBigInt' Case 3: MyStr = 'adBigInt' Case 13: MyStr = 'adBigInt' Case 205: MyStr = 'adBigInt' Case 201: MyStr = 'adBigInt' Case 203: MyStr = 'adBigInt' Case 131: MyStr = 'adBigInt' Case 138: MyStr = 'adBigInt' Case 4: MyStr = 'adBigInt' Case 2: MyStr = 'adBigInt' Case 16: MyStr = 'adBigInt' Case 21: MyStr = 'adBigInt' Case 19: MyStr = 'adBigInt' Case 18: MyStr = 'adBigInt' Case 17: MyStr = 'adBigInt' Case 132: MyStr = 'adBigInt' Case 204: MyStr = 'adBigInt' Case 200: MyStr = 'adBigInt' Case 12: MyStr = 'adBigInt' Case 139: MyStr = 'adBigInt' Case 202: MyStr = 'adBigInt' Case 130: MyStr = 'adBigInt' Case Else: MyStr = 'Error' End Select IntToString = MyStr End Function'6.窗体退出Private Sub 退出_Click() cnn.Close Set rs = Nothing Set cnn = Nothing Unload 数据表维护End Sub'二、列表框和输入框相关代码'1.'数据表'列表框，单击选择时刷新所选表的字段列表Private Sub 数据表清单_Click() Call 获取字段清单End Sub'2.'字段'列表框，单击选择时获取字段信息Private Sub 字段清单_Click() Call 获取字段信息End Sub'三、数据表相关操作代码'1.创建数据表Private Sub 创建数据表_Click() 创建数据表窗体.Show Call 获取数据表清单End Sub'2.移除数据表Private Sub 移除数据表_Click() Dim sql As String '判断是否选择了要删除的数据表 If 数据表清单.ListIndex = -1 Then MsgBox '没有选择要删除的数据表！', vbCritical, '警告' Exit Sub End If '确认是否删除选择的数据表 If MsgBox('是否删除数据表? ', vbQuestion + vbYesNo) = vbNo _ Then Exit Sub '删除选定的数据表 sql = 'drop table ' & 数据表清单.Text cnn.Execute sql MsgBox '数据库 & 数据表清单.Text & '>被成功删除！', vbInformation + vbOKOnly, '删除数据表' '刷新'数据表清单'列表框 Call 获取数据表清单 '删除'字段清单'列表框中的项目 字段清单.ClearEnd Sub'3.重命名数据表Private Sub 重命名数据表_Click() Dim sql As String, mynewname As String '判断是否选择了要重命名的数据表 If 数据表清单.ListIndex = -1 Then MsgBox '没有选要重命名的数据表！', vbCritical, '警告' Exit Sub End If '确认是否重命名选择的数据表 If MsgBox('是否重命名数据表? ', vbQuestion + vbYesNo) = vbNo _ Then Exit Sub restart: '指定数据表的新名称 mynewname = InputBox('请输入数据表新名称：', '输入数据表名称') If Len(Trim(mynewname)) = 0 Then 'trim函数可以去除空格 MsgBox '没有输入有效的数据表名称！', vbCritical, '警告' Exit Sub End If '检查是否存在同名的数据表 Set rs = cnn.OpenSchema(adSchemaTables) Do Until rs.EOF If LCase(rs!table_name) = LCase(mynewname) Then MsgBox '数据表 & mynewname & '>已经存在，请重新输入！', vbCritical, '警告' GoTo restart End If rs.MoveNext Loop '查询原数据表，生成新表名，删除原表达到重命名的效果 sql = 'select * into ' & mynewname & ' from ' & 数据表清单.Text cnn.Execute sql sql = 'drop table ' & 数据表清单.Text cnn.Execute sql MsgBox '成功将数据表名称改为 mynewname & '>', vbInformation + vbOKOnly, '数据表重命名' '刷新'数据表清单'列表框 Call 获取数据表清单 '删除'字段清单'列表框中的项目 字段清单.Clear Set rs = NothingEnd Sub'4.备份数据表Private Sub 备份数据表_Click() Dim sql As String, mynewname As String '判断是否选择了要备份的数据表 If 数据表清单.ListIndex = -1 Then MsgBox '没有选则要备份的数据表！', vbCritical, '警告' Exit Sub End If '确认是否备份选择的数据表 If MsgBox('是否备份数据表 & 数据表清单.Text & '>? ', vbQuestion + vbYesNo) = vbNo _ Then Exit Sub restart: '指定数据表的新名称 mynewname = InputBox('请输入数据表新名称：', '输入数据表名称') If Len(Trim(mynewname)) = 0 Then 'trim函数可以去除空格 MsgBox '没有输入有效的数据表名称！', vbCritical, '警告' Exit Sub End If '检查是否存在同名的数据表 Set rs = cnn.OpenSchema(adSchemaTables) Do Until rs.EOF If LCase(rs!table_name) = LCase(mynewname) Then MsgBox '数据表已经存在，请重新输入！', vbCritical, '警告' GoTo restart End If rs.MoveNext Loop '利用生成表查询达到备份的效果 sql = 'select * into ' & mynewname & ' from ' & 数据表清单.Text cnn.Execute sql MsgBox '成功将数据表 & 数据表清单.Text & '>备份，名称为 & _ mynewname & '>', vbInformation + vbOKOnly, '备份数据表' '刷新'数据表清单'列表框 Call 获取数据表清单 '删除'字段清单'列表框中的项目 字段清单.Clear Set rs = Nothing End Sub'四、字段操作相关代码'1.添加字段Private Sub 添加字段_Click() Dim sql As String, mynewfield As String '判断是否选择了要添加字段的数据表 If 数据表清单.ListIndex = -1 Then MsgBox '没有选要添加字段的数据表！', vbCritical, '警告' Exit Sub End If restart: '指定新字段名称 mynewfield = InputBox('请输入新字段名称：', '输入新字段') If Len(Trim(mynewfield)) = 0 Then 'trim函数可以去除空格 MsgBox '没有输入有效的字段名！', vbCritical, '警告' Exit Sub End If '确认是否添加字段 If MsgBox('是否向数据表 & 数据表清单.Text & '>中添加字段 _ & mynewfield & '>? ', vbQuestion + vbYesNo) = vbNo _ Then Exit Sub '检查是否存在同名的数据表 Set rs = cnn.OpenSchema(adSchemaColumns) Do Until rs.EOF If LCase(rs!column_name) = LCase(mynewfield) Then MsgBox '数据表中已经存在字段 & mynewfield & '>，请重新输入！', vbCritical, '警告' GoTo restart End If rs.MoveNext Loop '添加字段 sql = 'alter table ' & 数据表清单.Text & ' add ' & mynewfield & ' text(50)' cnn.Execute sql MsgBox '数据表 & 数据表清单.Text & '>中成功添加了字段 & _ mynewfield & '>', vbInformation + vbOKOnly, '添加字段' '刷新'字段清单'列表框 Call 获取字段清单 Set rs = NothingEnd Sub'2.删除字段Private Sub 删除字段_Click() '略...同添加字段类似End Sub'3.改变字段类型Private Sub 改变字段类型_Click() '略...同添加字段类似End Sub'4.改变字段大小Private Sub 改变字段大小_Click() '略...同添加字段类似End Sub