「代码」EXCEL VBA操作ACCESS数据库表(创建、修改、删除)，ADO的OpenSchema方法，获取所有表名【扩展篇】

Private Sub CmdCreate_Click()    '//新建一个表：tb销售'    On Error Resume Next    If IsTableExists("tb销售") Then        MsgBox "已存在【tb销售】！"        Exit Sub    End If    sql = "Create table tb销售 " _        & "(ID AUTOINCREMENT primary key,日期 Date," _        & "销售单号 text(255),产品名称 text(255)," _        & "数量 double,单价 double,金额 double," _        & "业务员 text(255),备注 text(255))"    Call ExecuteSQL(sql)    MsgBox "Done!"End Sub
Private Sub CmdCreate2_Click()    '//根据tb员工表建立另一个表    tbl = "tb员工bak"    If IsTableExists(tbl) Then        MsgBox "已存在【" & tbl & "】！"        Exit Sub    End If        sql = "select * into tb员工bak from tb员工"    'sql = "select * into tb员工bak from tb员工 where false"    'sql = "select 姓名,年龄 into tb员工bak from tb员工"        Call ExecuteSQL(sql)    MsgBox "创建成功！"End Sub
Private Sub CmdDeleteTable_Click()    '//删除表    tbl = "tb员工bak"    If Not IsTableExists(tbl) Then        MsgBox "不存在【" & tbl & "】！"        Exit Sub    End If        sql = "DROP TABLE " & tbl    Call ExecuteSQL(sql)    MsgBox "删除成功！"    End Sub
Private Sub CmdAllTables_Click()    '//显示所有表    Dim arr(), i As Integer    Dim strMsg As String    dbs = ThisWorkbook.Path & "\DataBase1101.accdb"    arr = getAllTables(dbs)    For i = LBound(arr) To UBound(arr)        strMsg = strMsg & arr(i) & Chr(10)    Next    MsgBox "所有表名如下:" & Chr(10) & strMsg    End Sub
Private Sub CmdAlterTable1_Click()    '//把tb销售表中的“日期"类型修改为文本    dbs = ThisWorkbook.Path & "\DataBase1101.accdb"    tbl = "tb销售"        '//先检查一下“日期”是否存在    If Not IsFieldExists(dbs, tbl, "日期") Then        MsgBox "不存在字段【日期】！"        Exit Sub    End If           '// 日期修改为文本    sql = " ALTER TABLE tb销售 ALTER COLUMN 日期 TEXT(50) "        Call ExecuteSQL(sql)        MsgBox "成功修改！"    End Sub
Private Sub CmdAlterTable2_Click()   '//把tb销售表中的“日期"类型修改为日期    dbs = ThisWorkbook.Path & "\DataBase1101.accdb"    tbl = "tb销售"        '//先检查一下“日期”是否存在    If Not IsFieldExists(dbs, tbl, "日期") Then        MsgBox "不存在字段【日期】！"        Exit Sub    End If           '// 日期修改为日期类型    sql = " ALTER TABLE tb销售 ALTER COLUMN 日期 Date "        Call ExecuteSQL(sql)        MsgBox "成功修改！"    End Sub
Private Sub CmdAlterTable3_Click()   '//在tb销售表中添加“销售类型”字段   Dim fieldName As String    dbs = ThisWorkbook.Path & "\DataBase1101.accdb"    tbl = "tb销售"    fieldName = "销售类型"        '//先检查一下“销售类型”是否存在    If IsFieldExists(dbs, tbl, fieldName) Then        MsgBox "已存在字段【" & fieldName & "】！"        Exit Sub    End If           '// 添加字段    sql = " ALTER TABLE tb销售 ADD " & fieldName & " TEXT(10) "        Call ExecuteSQL(sql)        MsgBox "添加成功！"    End Sub
Private Sub CmdAlterTable4_Click()   '//在tb销售表中删除“销售类型”字段   Dim fieldName As String    dbs = ThisWorkbook.Path & "\DataBase1101.accdb"    tbl = "tb销售"    fieldName = "销售类型"        '//先检查一下“销售类型”是否存在    If Not IsFieldExists(dbs, tbl, fieldName) Then        MsgBox "不存在字段【" & fieldName & "】！"        Exit Sub    End If       '// 删除字段    sql = " ALTER TABLE tb销售 DROP " & fieldName        Call ExecuteSQL(sql)        MsgBox "删除成功！"    End Sub

Dim sql As StringFunction IsTableExists(tableName As String) As Boolean    Dim blnFound As Boolean        dbs = ThisWorkbook.Path & "\DataBase1101.accdb"        '//打开数据库连接    Call OpenConnection(dbs)        '//查询表信息    Set rs = conn.OpenSchema(20)    blnFound = False        '//遍历表信息，检查是否存在指定的表名    Do Until rs.EOF    If rs!TABLE_NAME = tableName Then        blnFound = True        Exit Do    End If    rs.MoveNext    Loop        rs.Close    conn.Close    Set rs = Nothing    Set conn = Nothing     IsTableExists = blnFoundEnd Function
Function getAllTables(dbs As String)    Dim arr(), i As Integer    '//打开数据库连接    Call OpenConnection(dbs)     '//查询表信息    Set rs = conn.OpenSchema(20)    Do Until rs.EOF        If rs("table_type") = "TABLE" Then            If Left(rs("table_name"), 1) <> "~" Then                ReDim Preserve arr(i)                                arr(i) = rs("table_name")                i = i + 1            End If        End If        rs.MoveNext    Loop    rs.Close    conn.Close    Set rs = Nothing    Set conn = Nothing        getAllTables = arr
End Function

Function IsFieldExists(dbs As String, tbl As String, fieldName As String) As Boolean    Dim blnFound As Boolean    Dim i As Integer        '//打开数据库连接    Call OpenConnection(dbs)    Set rs = CreateObject("ADODB.Recordset")        blnFound = False    sql = "select * from " & tbl & " where 1=0"    Set rs = conn.Execute(sql)        For i = 0 To rs.Fields.Count - 1        If rs.Fields(i).Name = fieldName Then            blnFound = True            Exit For        End If    Next
    rs.Close    conn.Close    Set rs = Nothing    Set conn = Nothing
    IsFieldExists = blnFoundEnd Function