1-- Sub excel创建access数据库() Dim myDatabase As DAO.Database '定义数据库变量 Dim myDataTable As DAO.TableDef '定义数据表变量 Dim myDatabaseName As String '定义数据库名称 Dim myDataTableName As String '定义数据表名称 myDatabaseName = ThisWorkbook.Path & "\小爪.mdb" myDataTableName = "小爪成绩表" '删除已经存在的数据库文件 On Error Resume Next Kill myDatabaseName On Error GoTo 0 '创建数据库文件 Set myDatabase = CreateDatabase(myDatabaseName, dbLangGeneral) '创建数据表 Set myDataTable = myDatabase.CreateTableDef(myDataTableName) '为数据表添加字段 With myDataTable .Fields.Append .CreateField("学号", dbText, 8) .Fields.Append .CreateField("姓名", dbText, 6) .Fields.Append .CreateField("性别", dbText, 1) .Fields.Append .CreateField("学科", dbText, 20) .Fields.Append .CreateField("成绩", dbSingle) End With '将数据表添加到数据库对象中 myDatabase.TableDefs.Append myDataTable Set myDatabase = Nothing '释放变量 '弹出信息 MsgBox "创建数据库成功!" & vbCrLf _ & "数据库文件名为:" & myDatabaseName & vbCrLf _ & "数据表名称为:" & myDataTableName & vbCrLf _ & "保存位置:当前工作簿所在的文件夹。", _ vbokonluy + vbInformation, "创建数据库" End Sub
2--Public Sub 创建的数据库名称() Dim myData As String Dim myDb As DAO.Database '指定要创建的数据库名称 myData = ThisWorkbook.Path & "\NewData.mdb" '判断数据库文件是否存在,如果存在,就删除它 If Dir(myData) <> "" Then Kill myData '创建数据库 Set myDb = CreateDatabase(myData, dbLangChineseSimplified) MsgBox "数据库创建成功!", vbInformation, "创建数据库" '关闭数据库 myDb.Close '释放变量 Set myDb = Nothing End Sub
3--'创建数据库 Set myDb = CreateDatabase(myData, dbLangChineseSimplified & ";pwd=H1X2L3") MsgBox "数据库创建成功!密码为:H1X2L3", vbInformation, "创建数据库"
4--Public Sub 创建数据库() Dim myData As String, myTable As String Dim myDb As DAO.Database Dim myTbl As DAO.TableDef Dim myIndex As DAO.Index myData = ThisWorkbook.Path & "\职工信息.mdb" '指定要创建的数据库名称 myTable = "基本资料" '指定要创建的数据表名称 If Dir(myData) <> "" Then Kill myData '判断数据库文件是否存在,如果存在,就删除它 Set myDb = CreateDatabase(myData, dbLangChineseSimplified) '创建数据库 Set myTbl = myDb.CreateTableDef(myTable) '创建数据表 Set myIndex = myTbl.CreateIndex("编号主键") '创建索引 '为创建的数据表添加各个字段 With myTbl .Fields.Append .CreateField("编号", dbText, 10) .Fields.Append .CreateField("姓名", dbText, 6) .Fields.Append .CreateField("性别", dbText, 1) .Fields.Append .CreateField("部门", dbText, 10) .Fields.Append .CreateField("出生日期", dbDate) .Fields.Append .CreateField("基本工资", dbSingle) .Fields.Append .CreateField("备注", dbText, 50) '设置字段是否为必填字段 .Fields("编号").Required = True .Fields("姓名").Required = True .Fields("性别").Required = True .Fields("出生日期").Required = True .Fields("基本工资").Required = False .Fields("备注").Required = False '设置字段是否允许零长度的空字符串 .Fields("编号").AllowZeroLength = False .Fields("姓名").AllowZeroLength = False .Fields("性别").AllowZeroLength = False .Fields("出生日期").AllowZeroLength = False .Fields("基本工资").AllowZeroLength = False .Fields("备注").AllowZeroLength = False '创建主键索引 myIndex.Fields.Append myIndex.CreateField("编号") .Indexes.Append myIndex '将索引添加到索引集合中 '设置索引为主键,并且不允许重复 .Indexes("编号主键").Primary = True .Indexes("编号主键").Unique = True End With myDb.TableDefs.Append myTbl '将创建的数据表添加到数据库的TableDefs集合中 myDb.Close '关闭数据库,并'释放变量 Set myDb = Nothing Set myTbl = Nothing '弹出信息 MsgBox "创建数据库成功!" & vbCrLf & "数据库文件名为:" & myData & vbCrLf _ & "数据表名称为:" & myTable & vbCrLf _ & "保存位置:" & ThisWorkbook.Path, vbInformation, "创建数据库" End Sub
5--Public Sub 根据工作表创建数据库() Dim myDb As DAO.Database Dim myTable As DAO.TableDef Dim myIndex As DAO.Index Dim ws As Worksheet Dim i As Long Dim myData As String '判断工作表是否存在 On Error Resume Next Set ws = Worksheets("数据表设计") On Error GoTo 0 If ws Is Nothing Then MsgBox "没有数据表资料存在!", vbCritical, "警告" Exit Sub End If ws.Activate myData = ThisWorkbook.Path & "\" & Range("B1").Value & ".mdb" '删除已经存在的数据库 If Dir(myData) <> "" Then Kill myData '创建新数据库 Set myDb = CreateDatabase(myData, dbLangChineseSimplified) '创建数据表 Set myTable = myDb.CreateTableDef(Range("B2").Value) '创建索引 Set myIndex = myTable.CreateIndex("PrimaryKey") myIndex.Primary = True '开始为数据表添加字段 For i = 5 To Range("A65536").End(xlUp).Row With myTable .Fields.Append .CreateField(Cells(i, 1).Value, _ GetConstNo(Cells(i, 2).Value), Cells(i, 3).Value) If Cells(i, 2).Value = "dbText" Then If Cells(i, 4).Value = "True" Then .Fields(Cells(i, 1).Value).AllowZeroLength = True End If End If If Cells(i, 5).Value = "True" Then .Fields(Cells(i, 1).Value).Required = True Else .Fields(Cells(i, 1).Value).Required = False End If If Cells(i, 6).Value = "是" Then myIndex.Fields.Append myIndex.CreateField(Cells(i, 1).Value) End If End With Next i '将索引添加到索引集合中 myTable.Indexes.Append myIndex '将数据表添加到数据表集合中 myDb.TableDefs.Append myTable '弹出信息 MsgBox "数据库创建成功!" & vbCrLf & vbCrLf _ & "数据库名称为:" & ws.Range("B1").Value & ".mdb" & vbCrLf _ & "数据表名称为:" & ws.Range("B2").Value & vbCrLf _ & "保存位置为:" & ThisWorkbook.Path, _ vbOKOnly + vbInformation, "创建数据库和数据表" '关闭数据库联接,并释放变量 myDb.Close Set ws = Nothing Set myIndex = Nothing Set myTable = Nothing Set myDb = Nothing End Sub
'连上面程序
Function GetConstNo(myStr As String) As Integer Select Case myStr Case "dbBoolean": GetConstNo = 1 Case "dbByte": GetConstNo = 2 Case "dbInteger": GetConstNo = 3 Case "dbLong": GetConstNo = 4 Case "dbCurrency": GetConstNo = 5 Case "dbSingle": GetConstNo = 6 Case "dbDouble": GetConstNo = 7 Case "dbDate": GetConstNo = 8 Case "dbBinary": GetConstNo = 9 Case "dbText": GetConstNo = 10 Case "dbLongBinary": GetConstNo = 11 Case "dbMemo": GetConstNo = 12 Case "dbGUID": GetConstNo = 15 Case "dbBigInt": GetConstNo = 16 Case "dbVarBinary": GetConstNo = 17 Case "dbChar": GetConstNo = 18 Case "dbNumeric": GetConstNo = 19 Case "dbDecimal": GetConstNo = 20 Case "dbFloat": GetConstNo = 21 Case "dbTime": GetConstNo = 22 Case "dbTimeStamp": GetConstNo = 23 Case Else: GetConstNo = -1 End Select End Function
**********************************************************************
B \ 在excel打开指定的acc表
Sub 在excel打开指定的acc表() Dim myaccess As Access.Application Dim myDatabaseName As String '定义数据库名称 Dim myDataTableName As String '定义数据表名称 '设置要打开的数据库名称(包括完整路径) myDatabaseName = ThisWorkbook.Path & "\小爪.mdb" '设置要打开的数据表名称 myDataTableName = "小爪成绩表" '设置数据库变量 Set myaccess = GetObject(myDatabaseName) '使打开的数据库可见 myaccess.Visible = True '打开指定的数据表 myaccess.DoCmd.OpenTable myDataTableName '最大化数据表窗口 myaccess.DoCmd.Maximize '释放变量 Set myaccess = Nothing End Sub
*****************************************************************
C\ Sub Excel用msgbox读取Access() Dim mydata As String, mytable As String, n As Integer Dim cnn As ADODB.Connection Dim rs As ADODB.Recordset mydata = ThisWorkbook.Path & "\客户管理.mdb" mytable = "客户资料" Set cnn = New ADODB.Connection With cnn .Provider = "microsoft.jet.oledb.4.0" .Open mydata End With Set rs = New ADODB.Recordset rs.Open mytable, cnn, adOpenKeyset, adLockOptimistic n = rs.RecordCount MsgBox "与数据库 " & mydata & "连接成功!" & vbCrLf & vbCrLf _ & "在数据库的" & mytable & "表中共有 " & n & " 条记录。", _ vbInformation, "连接数据库" For i = 1 To n MsgBox "编号为:" & rs.Fields("客户编号") & "的客户信息:" _ & vbCrLf & vbCrLf _ & "客户名称:" & rs.Fields("客户名称") & vbCrLf _ & "客户地址:" & rs.Fields("通讯地址") & vbCrLf _ & "邮政编码:" & rs.Fields("邮政编码") & vbCrLf _ & "联系电话:" & rs.Fields("联系电话"), _ vbInformation, "客户信息" rs.MoveNext Next i rs.Close cnn.Close Set rs = Nothing Set cnn = Nothing End Sub
*******************************************************
D\ Sub Excel用单元格记录Access表内容方法A() Dim myrow As Integer, mycol As Integer Dim cnn As ADODB.Connection Dim rs As ADODB.Recordset Dim mydata As String, mytable As String Dim mysheet As Worksheet mydata = ThisWorkbook.Path & "\客户管理.mdb" mytable = "客户资料" '建立与数据库的廉洁 Set cnn = New ADODB.Connection With cnn .Provider = "microsoft.jet.oledb.4.0;" .Open mydata End With '查询数据表 Set rs = New ADODB.Recordset rs.Open mytable, cnn, adOpenKeyset, adLockOptimistic Set mysheet = ThisWorkbook.Sheets(1) mysheet.Cells.ClearContents '复制字段名 For mycol = 1 To rs.Fields.Count mysheet.Cells(1, mycol) = rs.Fields(mycol - 1).Name Next mycol '复制记录数据 mysheet.Range("A2").CopyFromRecordset rs '自动调整工作表 mysheet.Cells.Columns.AutoFit mysheet.Cells(1, 1).Select rs.Close cnn.Close Set rs = Nothing Set cnn = Nothing End Sub
**********************************************************
E\ Sub Excel窗体的textbox数值添加到指定ACC中() Dim i As Integer res = MsgBox("准备添加当前的记录到数据库中!真要添加吗?", vbYesNo + vbQuestion, "添加记录") If res = vbNo Then Exit Sub '检查各个项目是否为空值 If TextBoxIsEmpty(客户编号, "客户编号") = True Then Exit Sub If TextBoxIsEmpty(客户名称, "客户名称") = True Then Exit Sub If TextBoxIsEmpty(通讯地址, "通讯地址") = True Then Exit Sub If TextBoxIsEmpty(邮政编码, "邮政编码") = True Then Exit Sub If TextBoxIsEmpty(联系电话, "联系电话") = True Then Exit Sub If TextBoxIsEmpty(传真号码, "传真号码") = True Then Exit Sub If TextBoxIsEmpty(EMail, "e-mail") = True Then Exit Sub If TextBoxIsEmpty(联系人姓名, "联系人姓名") = True Then Exit Sub If TextBoxIsEmpty(联系人电话, "联系人电话") = True Then Exit Sub If TextBoxIsEmpty(信用等级, "信用等级") = True Then Exit Sub '检查输入的客户编号是否唯一 For i = 1 To rs.RecordCount If rs.Fields("客户编号") = 客户编号.Value Then MsgBox "数据库中已经存在了一个客户编号 " & 客户编号.Value _ & " !请重新输入编号!", vbCritical, "警告" 客户编号.Value = "" 客户编号.SetFocus Exit Sub End If Next i '将窗体数据添加到数据表 rs.AddNew rs.Fields("客户编号") = 客户编号.Value rs.Fields("客户名称") = 客户名称.Value rs.Fields("通讯地址") = 通讯地址.Value rs.Fields("邮政编码") = 邮政编码.Value rs.Fields("联系电话") = 联系电话.Value rs.Fields("传真号码") = 传真号码.Value rs.Fields("E-mail") = EMail.Value rs.Fields("联系人姓名") = 联系人姓名.Value rs.Fields("联系人电话") = 联系人电话.Value rs.Fields("信用等级") = 信用等级.Value rs.Update 显示条.Caption = "在数据库中共有 " & rs.RecordCount & " 条记录。" End Sub
*********************************************************
F\ Sub Excel单元格数值添加到指定ACC中记录并更新() Dim mydata As String Dim TableExists As Boolean Dim myaccess As Access.Application Dim myCmd As ADODB.Command Dim SQL As String Dim cnn As ADODB.Connection Dim rs As ADODB.Recordset Dim ws As Worksheet Set ws = Sheet1 mydata = ThisWorkbook.Path & "\学生管理.mdb" '判断是否有"学生管理.mdb"文件,如果没有,就创建它 Set fs = CreateObject("Scripting.FileSystemObject") If fs.FileExists(mydata) = False Then Application.StatusBar = "正在创建数据库......" Set myaccess = CreateObject("Access.Application") myaccess.NewCurrentDatabase mydata myaccess.CloseCurrentDatabase Set myaccess = Nothing End If '建立与数据库"学生管理.mdb"的连接 Application.StatusBar = "正在建立与数据库的连接......" Set cnn = New ADODB.Connection With cnn .Provider = "microsoft.jet.oledb.4.0" .Open mydata End With '判断是否有数据表"学生信息",如果没有.就创建它 TableExists = False Set rs = cnn.OpenSchema(adSchemaTables) Do Until rs.EOF Application.StatusBar = "正在检查数据表......" If LCase(rs!table_name) = LCase("学生信息") Then TableExists = True Exit Do End If rs.MoveNext Loop If TableExists = False Then Application.StatusBar = "正在创建数据表......" Set myCmd = New ADODB.Command Set myCmd.ActiveConnection = cnn myCmd.CommandText = "create table 学生信息 (学号 text(10),姓名 text(4)," _ & "性别 text(1),系别 text(20),班级 text(10),面貌 text(2)," _ & "出生日期 date,籍贯 text(10))" myCmd.Execute , , adCmdText Set myCmd = Nothing End If '删除数据表中原有的全部记录 Application.StatusBar = "正在删除原有的全部记录......" SQL = "delete from 学生信息" Set rs = New ADODB.Recordset rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic '向数据表中添加新记录 SQL = "select * from 学生信息" Set rs = New ADODB.Recordset rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic For i = 2 To ws.Range("A65536").End(xlUp).Row Application.StatusBar = "正在向数据库添加学生信息记录......" rs.AddNew rs.Fields("学号") = ws.Cells(i, 1) rs.Fields("姓名") = ws.Cells(i, 2) rs.Fields("性别") = ws.Cells(i, 3) rs.Fields("系别") = ws.Cells(i, 4) rs.Fields("班级") = ws.Cells(i, 5) rs.Fields("面貌") = ws.Cells(i, 6) rs.Fields("出生日期") = ws.Cells(i, 7) rs.Fields("籍贯") = ws.Cells(i, 8) rs.Update Next i rs.Close cnn.Close Set rs = Nothing Set cnn = Nothing Application.StatusBar = False End Sub
************************************************************
G\ Sub Excel用单元格记录Access表内容方法B() Dim cnn As ADODB.Connection Dim rs As ADODB.Recordset Dim mydata As String, mySQL As String mydata = ThisWorkbook.Path & "\学生管理.mdb" Set cnn = New ADODB.Connection Set cnn = New ADODB.Connection With cnn .Provider = "microsoft.jet.oledb.4.0" .Open mydata End With Set rs = New ADODB.Recordset mySQL = "select * from 学生信息" rs.Open mySQL, cnn, adOpenKeyset, adLockOptimistic For iCols = 0 To rs.Fields.Count - 1 Sheet1.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name Next iCols Sheet1.Cells(2, 1).CopyFromRecordset rs rs.Close cnn.Close Set rs = Nothing Set cnn = Nothing End Sub
|