VBA：强大的数据库创建

Question

我在尝试使用 adodb 和 adox 创建数据库时找到了这段代码。

Here you can check original, it is the same. Thanks for author

Private Sub Command1_Click()
Dim db_file As String
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim num_records As Integer

' Get the database name.
db_file = App.Path
If Right$(db_file, 1) <> "\" Then db_file = db_file & _
    "\"
db_file = db_file & "People.mdb"

' Open a connection.
Set conn = New ADODB.Connection
conn.ConnectionString = _
    "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & db_file & ";" & _
    "Persist Security Info=False"
conn.Open

' Drop the Employees table if it already exists.
On Error Resume Next
conn.Execute "DROP TABLE Employees"
On Error GoTo 0

' Create the Employees table.
conn.Execute _
    "CREATE TABLE Employees(" & _
        "EmployeeId INTEGER      NOT NULL," & _
        "LastName   VARCHAR(40)  NOT NULL," & _
        "FirstName  VARCHAR(40)  NOT NULL)"

' Populate the table.
conn.Execute "INSERT INTO Employees VALUES (1, " & _
    "'Anderson', 'Amy')"
conn.Execute "INSERT INTO Employees VALUES (1, 'Baker', " & _
    "   'Betty')"
conn.Execute "INSERT INTO Employees VALUES (1, 'Cover', " & _
    "   'Chauncey')"
' Add more records ...

' See how many records the table contains.
Set rs = conn.Execute("SELECT COUNT (*) FROM Employees")
num_records = rs.Fields(0)

conn.Close

MsgBox "Created " & num_records & " records", _
    vbInformation, "Done"
End Sub

但是如何让它更健壮，所以，我不想删除 db。

如何检查 db 是否存在以及 db.tables 是否包含我的表？

附加问题：我说得对吗，这段代码为 ms-access 2007 创建了数据库？

感谢您的帮助！

Answer 1

您的问题包括以下两个：

1. 如何检查 db 是否存在以及 db.tables 是否包含我的表？
2. 我是对的，这段代码为 ms-access 2007 创建了数据库吗？

对于#1 的第一部分，使用 Dir() 函数。

If Len(Dir("C:\SomeFolder\YourDb.mdb")) > 0 Then
    Debug.Print "db exists"
Else
    Debug.Print "db not found"
End If

对于#1 的第二部分，试试这个函数。 pTable 是您要检查的表的名称。 pDbPath 是您要检查的 db 文件的完整路径，包括文件名。路径可以是以驱动器号开头的路径，也可以是 UNC 路径 (\\Server\Share\YourDb.mdb)。

Public Function TableExists(ByVal pTable As String, _
        Optional ByVal pDbPath As String) As Boolean
    'return True if pTable exists as either a native or linked table '
    'pass any error to caller '
    Dim blnReturn As Boolean
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef

    If Len(Trim(pDbPath)) > 0 Then
        Set db = OpenDatabase(pDbPath)
    Else
        Set db = CurrentDb
    End If

    For Each tdf In db.TableDefs
        If tdf.Name = pTable Then
            blnReturn = True
            Exit For
        End If
    Next tdf

    Set tdf = Nothing
    If Len(Trim(pDbPath)) > 0 Then
        db.Close
    End If
    Set db = Nothing
    TableExists = blnReturn
End Function

关于您的第二个问题，您向我们展示的代码不会为任何 Access 版本创建 db 文件。如果db_file 不是现有数据库文件的路径，则该代码将在conn.Open 处引发错误。它不会创建丢失的 db 文件。

但是我怀疑代码是否会编译为 VBA，尽管事实上您在标题中包含了 VBA 并将您的问题标记为 vba。确实，您至少应该先尝试一下，然后再将其包含在 Stack Overflow 上的问题中。

Answer 2

要从 VB6/VBA 代码创建 MDB 文件，您可以使用 ADOX。这是创建 MDB 文件的示例函数。

Public Function CreateMDB(strDBPath As String) As Boolean
'To make code compile add a reference to Microsoft ADO Ext 2.x for DDL and Security 
'(msADOX.dll)
Dim catDB As ADOX.Catalog
Dim tblNew As ADOX.Table
Dim keyPrim As New ADOX.Key

    Set catDB = New ADOX.Catalog

    If Dir(strDBPath) = "" Then
        CreateMDB = False
    End If

    With catDB
        .Create "Provider=Microsoft.Jet.OLEDB.4.0;Locale Identifier=" & _
            1033 & ";Data Source=" & strDBPath
        .ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
            "Data Source=" & strDBPath
    End With

    Set tblNew = New ADOX.Table
    With tblNew
        .Name = "data"
        With .Columns
            .Append "Field_0", adVarWChar
            .Append "Field_1", adVarWChar
            .Append "Field_2", adVarWChar
            .Append "Field_3", adVarWChar
        End With
    End With
    catDB.Tables.Append tblNew

    Set keyPrim = New ADOX.Key
    With keyPrim
        .Name = "Field_0"
        .Type = adKeyPrimary
        .RelatedTable = "data"
        .Columns.Append "Field_0"
    End With
    catDB.Tables("data").Keys.Append keyPrim

    Set catDB = Nothing
    Set tblNew = Nothing

End Function