FYI: Creating and verifying Access Tables from scratch

[Lord_Rat]

I spent all day trying to make my program create a table dynamically and fix fields if they are not of a type I am expecting.

I couldn't find a case of someone already doing this, so this is an FYI post for any who are looking to do the same thing.

I like to keep my code as easy (for me) to use, so here is how you check a table:

'This code assumes a 'backup' folder exists under the sDataSet location
        Dim sDataSet As String = Application.ExecutablePath
        sDataSet = sDataSet.Remove(InStrRev(Application.ExecutablePath, "\"), Len(Application.ExecutablePath) - InStrRev(Application.ExecutablePath, "\")) 'defines the folder where the data is
        Dim tdTable As New TableDescription()
        With tdTable
            .PriKey = "PriKey" 'Primary Key field. Can be left blank
            .TableName = "Locations" 'Name of table to check
            .Fields = MakeArray("Location_Description", "Location_Database") 'field names
            .FieldTypes = MakeADOXArray(ADOX.DataTypeEnum.adVarWChar, ADOX.DataTypeEnum.adVarWChar) 'Field types of fields
            .MissingIsFatal = MakeBooleanArray(False, False) 'whether to throw an error is a field doesn't match
        End With
 
        VerifyDataBase("dataset.mdb", tdTable) 'Now verify the 'dataset.mdb' database

And the TableDescription Class...

Public Class TableDescription
    Private TName As String
    Private aFields() As String
    Private MFatal() As Boolean
    Private FTypes() As ADOX.DataTypeEnum
    Private PKey As String
 
    Property TableName() As String
        Get
            Return TName
        End Get
        Set(ByVal Value As String)
            TName = Value
        End Set
    End Property
 
    Property Fields() As String()
        Get
            Return aFields
        End Get
        Set(ByVal Value() As String)
            aFields = Value
        End Set
    End Property
 
    Property MissingIsFatal() As Boolean()
        Get
            Return MFatal
        End Get
        Set(ByVal Value() As Boolean)
            MFatal = Value
        End Set
    End Property
 
    Property FieldTypes() As ADOX.DataTypeEnum()
        Get
            Return FTypes
        End Get
        Set(ByVal Value() As ADOX.DataTypeEnum)
            FTypes = Value
        End Set
    End Property
 
    Property PriKey() As String
        Get
            Return PKey
        End Get
        Set(ByVal Value As String)
            PKey = Value
        End Set
    End Property
End Class

[Lord_Rat]

Due to message length, I had to make two posts:

And the functions:

Private Sub VerifyDataBase(ByVal dbName As String, ByVal tdTable As TableDescription)
        Dim objFile As Scripting.File
        Dim sDataSet As String = Application.ExecutablePath
        Dim sDataSet1 As String = ""
        Dim AcApp As New ADOX.Catalog()
        Dim oColumn As New ADOX.Column()
        Dim objTable As New ADOX.Table()
 
        If tdTable.Fields.GetUpperBound(0) <> tdTable.FieldTypes.GetUpperBound(0) Then
            throwError("VerifyDataBase Fields not FieldTypes")
            Exit Sub
        End If
        If tdTable.Fields.GetUpperBound(0) <> tdTable.MissingIsFatal.GetUpperBound(0) Then
            throwError("VerifyDataBase Fields not MissingIsFatal")
            Exit Sub
        End If
 
        sDataSet = sDataSet.Remove(InStrRev(Application.ExecutablePath, "\"), Len(Application.ExecutablePath) - InStrRev(Application.ExecutablePath, "\"))
        sDataSet1 = sDataSet & dbName
        If Not VerifyDataSource(sDataSet1) Then
            'The datasource could not be opened, so we are going to back it up if it exists and recreate it.
            If objFS.FileExists(sDataSet1) Then
                Try
                    objFS.CopyFile(sDataSet1, sDataSet & "\backup\" & System.DateTime.Now.ToFileTime().ToString() & ".mdb", True)
                Catch
                End Try
                objFile = objFS.GetFile(sDataSet1)
                objFile.Delete(True)
            End If
            Try
 
                AcApp.Create("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & sDataSet1)
 
                With objTable
                    .Name = tdTable.TableName
                    With .Columns
                        Dim iCounter As Integer
                        For iCounter = 0 To tdTable.Fields.GetUpperBound(0)
                            Select Case tdTable.FieldTypes(iCounter)
                                Case ADOX.DataTypeEnum.adInteger
                                    .Append(tdTable.Fields(iCounter), tdTable.FieldTypes(iCounter), 255)
                                Case Else
                                    .Append(tdTable.Fields(iCounter), tdTable.FieldTypes(iCounter))
                            End Select
                        Next
                    End With
                End With
                AcApp.Tables.Append(objTable)
 
                If tdTable.PriKey <> "" Then
                    ' Create a new AutoNumber ID Column
                    With oColumn
                        .Name = tdTable.PriKey
                        .Type = ADOX.DataTypeEnum.adInteger
                        .ParentCatalog = AcApp     ' Must set before setting properties
                        .Properties("AutoIncrement").Value = True
                    End With
                    AcApp.Tables(tdTable.TableName).Columns.Append(oColumn)
                    objTable.Keys.Append(tdTable.TableName, ADOX.KeyTypeEnum.adKeyPrimary, tdTable.PriKey)
                End If
 
            Catch ee As Exception
                throwError(sDataSet1 & vbCrLf & vbCrLf & ee.Message & vbCrLf & vbCrLf & "The file could not be opened. A new one could not be created either.")
                MyBase.Dispose()
                Exit Sub
            End Try
            throwError(sDataSet1 & vbCrLf & vbCrLf & "The file could not be opened. A new version has been created.")
        Else
            'Database exists, so check it to see if the fields are OK
            Dim AcConn As New ADODB.Connection()
            Dim modsMade As Boolean = False
            AcConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & sDataSet1
            AcConn.Open()
            AcApp.ActiveConnection = AcConn
            Try
                objTable = AcApp.Tables(tdTable.TableName)
            Catch
                objTable = New ADOX.Table()
                objTable.Name = tdTable.TableName
                AcApp.Tables.Append(objTable)
            End Try
            Dim objColumn As ADOX.Column
            Dim iCount As Integer
            Dim bFound() As Boolean
            ReDim bFound(tdTable.Fields.GetUpperBound(0) + 1)
            For iCount = 0 To tdTable.Fields.GetUpperBound(0)
                For Each objColumn In objTable.Columns
                    With objColumn
                        If .Name = tdTable.Fields(iCount) AndAlso .Type = tdTable.FieldTypes(iCount) Then
                            bFound(iCount) = True
                            Exit For
                        End If
                    End With
                Next
            Next
 
            Dim bFound2 As Boolean
            Dim objKey As ADOX.Key
            oColumn = New ADOX.Column()
            For Each objKey In objTable.Keys
                With objKey
                    If .Columns(0).Name = tdTable.PriKey AndAlso .Type = ADOX.KeyTypeEnum.adKeyPrimary AndAlso objTable.Columns(objKey.Columns(0).Name).Properties("AutoIncrement").Value = True Then
                        bFound2 = True
                        Exit For
                    End If
                End With
            Next
 
            If Not bFound2 Then
                'The datasource could not be opened, so we are going to back it up if it exists and recreate it.
                If objFS.FileExists(sDataSet1) Then
                    Try
                        objFS.CopyFile(sDataSet1, sDataSet & "\backup\" & System.DateTime.Now.ToFileTime().ToString() & ".mdb", True)
                    Catch
                    End Try
                    modsMade = True
                End If
 
                With oColumn
                    .Name = tdTable.PriKey
                    .Type = ADOX.DataTypeEnum.adInteger
                    .ParentCatalog = AcApp     ' Must set before setting properties
                    .Properties("AutoIncrement").Value = True
                End With
                Try
                    AcApp.Tables(tdTable.TableName).Columns.Delete(oColumn.Name)
                    AcApp.Tables.Refresh()
                Catch
                End Try
                AcApp.Tables(tdTable.TableName).Columns.Append(oColumn)
                objTable.Keys.Append(tdTable.TableName, ADOX.KeyTypeEnum.adKeyPrimary, tdTable.PriKey)
            End If
            For iCount = 0 To tdTable.Fields.GetUpperBound(0)
                If Not bFound(iCount) Then
                    If tdTable.MissingIsFatal(iCount) Then
                        throwError(sDataSet1 & vbCrLf & vbCrLf & "Column " & tdTable.Fields(iCount) & " of type " & tdTable.FieldTypes(iCount) & " not found.")
                        AcConn.Close()
                        Exit Sub
                    Else
                        'We are changing the data, including deleting a column, so make a backup:
                        If objFS.FileExists(sDataSet1) AndAlso Not modsMade Then
                            Try
                                objFS.CopyFile(sDataSet1, sDataSet & "\backup\" & System.DateTime.Now.ToFileTime().ToString() & ".mdb", True)
                            Catch
                            End Try
                            modsMade = True
                        End If
                        Try
                            AcApp.Tables(tdTable.TableName).Columns.Delete(tdTable.Fields(iCount))
                            AcApp.Tables.Refresh()
                        Catch
                        End Try
                        Select Case tdTable.FieldTypes(iCount)
                            Case ADOX.DataTypeEnum.adVarWChar
                                objTable.Columns.Append(tdTable.Fields(iCount), tdTable.FieldTypes(iCount), 255)
                            Case Else
                                objTable.Columns.Append(tdTable.Fields(iCount), tdTable.FieldTypes(iCount))
                        End Select
                    End If
                End If
            Next
            AcConn.Close()
        End If
    End Sub
 
    Private Sub throwError(ByVal inText)
        MsgBox(inText)
    End Sub
 
    Private Function MakeArray(ByVal ParamArray inObjects() As String) As String()
        Return inObjects
    End Function
 
    Private Function MakeADOXArray(ByVal ParamArray inObjects() As ADOX.DataTypeEnum) As ADOX.DataTypeEnum()
        Return inObjects
    End Function
 
    Private Function MakeBooleanArray(ByVal ParamArray inObjects() As Boolean) As Boolean()
        Return inObjects
    End Function
 
    Private Function VerifyDataSource(ByVal inMDBPath As String) As Boolean
        If objFS.FileExists(inMDBPath) Then
            objConn = New OleDb.OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
                inMDBPath)
            Try
                objConn.Open()
            Catch
                Return False
            End Try
        Else
            Return False
        End If
 
        VerifyDataSource = True
    End Function

Please recognize the author (me), Keith Ratliff, if you use the code or a majority of the code as-is.