Option Compare Database

Option Explicit

 

' 05/02/2009

'

' connect to an Access database

' display a list of tables

' select a table to view the fields

' can sort by ordinal position, alphabetical or data type

'

' requires:

'   a common dialog control

'   two list boxes

'   button to select database, text box to display the name

'   option group with 3 buttons to control the field sort order

 

Private Sub btnSelectDatabase_Click()

    Dim F As String

    With Me

        With .cdgDatabase

            .ShowOpen

            F = .FileName

        End With

        .txtDatabase = F

        ClearList "lstTables"

        ClearList "lstFields"

        If Nz(F, "") <> "" Then

            GetTables F

            .lstTables = Null

        End If

    End With

End Sub

 

Private Sub Form_Open(Cancel As Integer)

    ClearList "lstTables"

    ClearList "lstFields"

End Sub

 

Private Sub fraSort_AfterUpdate()

    GetFields

End Sub

 

Private Sub GetTables(F As String)

    Dim db As DAO.Database, qdf As DAO.QueryDef, rs As DAO.Recordset

    Dim sql As String

    '

    On Error GoTo err_sub

    '

    Set db = CurrentDb

    sql = "SELECT [name] FROM MSysObjects IN '" & F & "' "

    sql = sql & "WHERE [Type] = 1 AND LEFT([name],4) <> 'MSys' "

    Set qdf = db.CreateQueryDef("", sql)

    Set rs = qdf.OpenRecordset()

    If Not (rs.BOF And rs.EOF) Then

        rs.MoveFirst

        Do While Not rs.EOF

            Me.lstTables.AddItem rs.Fields(0)

            rs.MoveNext

        Loop

    End If

exit_sub:

    rs.Close

    Set rs = Nothing

    Set qdf = Nothing

    Set db = Nothing

    Exit Sub

    '

err_sub:

    MsgBox Err.Description, vbExclamation, "Error # " & Err.Number

    Resume exit_sub

    '

End Sub

 

Private Sub GetFields()

    Dim db As DAO.Database, qdf As DAO.QueryDef, fld As DAO.Field

    Dim sql As String, ThisDataType As String

    Dim rs As ADODB.Recordset

    '

    On Error GoTo err_sub

    '

    With Me

        If Nz(.txtDatabase, "") = "" Then Exit Sub

        '

        Set db = CurrentDb

        '

        Set rs = New ADODB.Recordset

        rs.Fields.Append "fieldname", adChar, 64

        rs.Fields.Append "datatype", adChar, 20

        rs.Open

        '

        ClearList "lstFields"

        sql = "SELECT * FROM [" & .lstTables & "] IN '" & .txtDatabase & "'"

        Set qdf = db.CreateQueryDef("", sql)

        For Each fld In qdf.Fields

            rs.AddNew

            rs.Fields("fieldname") = fld.Name

            ThisDataType = GetDataType(fld.Type)

            If ThisDataType = "Text" Then

                ThisDataType = ThisDataType & " ( " & fld.Size & " )"

            End If

            If (fld.Attributes And dbAutoIncrField) = dbAutoIncrField Then

                ThisDataType = "AutoNumber"

            End If

            rs.Fields("datatype") = ThisDataType

            rs.Update

        Next fld

        '

        Select Case .fraSort

            Case 1

                ' no sort applied

            Case 2

                rs.Sort = "fieldname"

            Case 3

                rs.Sort = "datatype,fieldname"

        End Select

        '

        rs.MoveFirst

        Do While Not rs.EOF

            .lstFields.AddItem rs.Fields("fieldname") & ";" & rs.Fields("datatype")

            rs.MoveNext

        Loop

    End With

    rs.Close

    Set rs = Nothing

    Set qdf = Nothing

    Set db = Nothing

exit_sub:

    Exit Sub

    '

err_sub:

    MsgBox Err.Description, vbExclamation, "Error # " & Err.Number

    Resume exit_sub

    '

End Sub

 

Private Sub lstTables_Click()

    GetFields

End Sub

 

Private Sub lstTables_DblClick(Cancel As Integer)

    GetFields

End Sub

 

Private Sub ClearList(listname As String)

    With Me.Controls(listname)

        Do While .ListCount > 0

            .RemoveItem 0

        Loop

    End With

End Sub

 

Private Function GetDataType(TypeNumber As Long) As String

    Select Case TypeNumber

        Case 1

            GetDataType = "Yes/No"

        Case 2

            GetDataType = "Byte"

        Case 3

            GetDataType = "Integer"

        Case 4

            GetDataType = "Long"

        Case 5

            GetDataType = "Currency"

        Case 6

            GetDataType = "Single"

        Case 7

            GetDataType = "Double"

        Case 8

            GetDataType = "Date/Time"

        Case 10

            GetDataType = "Text"

        Case 11

            GetDataType = "OLE Object"

        Case 12

            GetDataType = "Memo"

    End Select

End Function