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