赛味馆香辣猪肉脯:Excel创建acc数据库的几个方法

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

**************************************************

编后话：要想成为EXCEL高手，至少至少你要了解ACCESS与excel之间的桥

宗旨：熟悉熟练代码备以后查询代码之需。小爪只喜欢excel，e交友