How to loop through all Tables in an MS Access DB - ms-access

I need to read the properties of over 100 tables in an Access 2003 database and write those details - table name, field name, type and size - to a file for further documentation.
I can find nothing from web searches about reading field properties, just field values ...
Can someone please tell me what recordset variables I have to declare (and the syntax) to loop through all of the tables in the DB and extract the field name, type and size from each of them? I will be writing the results to a text file, but I think I can handle that! :)
I'm at a standstill until I can sort this out. It took me a day to document TWO tables manually. Some of the tables have well over 100 fields.

The Database Documenter wizard with these options should give you what you want with the least effort.
If that approach is not satisfactory, you can use custom VBA code to gather the information you want. You can retrieve the names of the tables in your database by looping through the DAO TableDefs collection.
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Set db = CurrentDb
For Each tdf In db.TableDefs
' ignore system and temporary tables
If Not (tdf.name Like "MSys*" Or tdf.name Like "~*") Then
Debug.Print tdf.name
End If
Next
Set tdf = Nothing
Set db = Nothing
To get the field details you want, adapt Allen Browne's TableInfo() function ... substitute file write statements for the Debug.Print statements. Note that function uses 2 helper functions, GetDescrip and FieldTypeName, both of which are included in that linked page.
Here is an Immediate window output sample from TableInfo() for a table in my database --- I think it includes the field information you want.
TableInfo "foo"
FIELD NAME FIELD TYPE SIZE DESCRIPTION
========== ========== ==== ===========
id AutoNumber 4
MyNumber Long Integer 4
MyText Text 255
bar Long Integer 4
========== ========== ==== ===========
After you've adapted the function, call it from the For Each tdf loop in the sample above and feed it each tdf.name:
TableInfo tdf.name

You're going to have to tweak this a bit, it's designed to copy tables from one database to another but it should be a great starting point.
' Database.
Dim dbRep As DAO.Database
Dim dbNew As DAO.Database
' For copying tables and indexes.
Dim tblRep As DAO.TableDef
Dim tblNew As DAO.TableDef
Dim fldRep As DAO.Field
Dim fldNew As DAO.Field
Dim idxRep As DAO.Index
Dim idxNew As DAO.Index
' For copying data.
Dim rstRep As DAO.Recordset
Dim rstNew As DAO.Recordset
Dim rec1 As DAO.Recordset
Dim rec2 As Recordset
Dim intC As Integer
' For copying table relationships.
Dim relRep As DAO.Relation
Dim relNew As DAO.Relation
' For copying queries.
Dim qryRep As DAO.QueryDef
Dim qryNew As DAO.QueryDef
' For copying startup options.
Dim avarSUOpt
Dim strSUOpt As String
Dim varValue
Dim varType
Dim prpRep As DAO.Property
Dim prpNew As DAO.Property
' For importing forms, reports, modules, and macros.
Dim appNew As New Access.Application
Dim doc As DAO.Document
' Open the database, not in exclusive mode.
Set dbRep = OpenDatabase(Forms!CMDB_frmUpgrade.TxtDatabase, False)
' Open the new database
Set dbNew = CurrentDb
DoEvents
' Turn on the hourglass.
DoCmd.Hourglass True
'********************
Debug.Print "Copy Tables"
'********************
If Forms!CMDB_frmUpgrade.CkTables = True Then
Forms!CMDB_frmUpgrade.LstMessages.addItem "Copying Tables:"
' Loop through the collection of table definitions.
For Each tblRep In dbRep.TableDefs
Set rec1 = dbRep.OpenRecordset("SELECT MSysObjects.Name FROM MsysObjects WHERE ([Name] = '" & tblRep.Name & "') AND ((MSysObjects.Type)=4 or (MSysObjects.Type)=6)")
If rec1.EOF Then
XF = 0
Else
XF = 1
End If
' Ignore system tables and CMDB tables.
If InStr(1, tblRep.Name, "MSys", vbTextCompare) = 0 And _
InStr(1, tblRep.Name, "CMDB", vbTextCompare) = 0 And _
XF = 0 Then
'***** Table definition
' Create a table definition with the same name.
Set tblNew = dbNew.CreateTableDef(tblRep.Name)
Forms!CMDB_frmUpgrade.LstMessages.addItem "--> " & tblRep.Name & ""
' Set properties.
tblNew.ValidationRule = tblRep.ValidationRule
tblNew.ValidationText = tblRep.ValidationText
' Loop through the collection of fields in the table.
For Each fldRep In tblRep.Fields
' Ignore replication-related fields:
' Gen_XXX, s_ColLineage, s_Generation, s_GUID, s_Lineage
If InStr(1, fldRep.Name, "s_", vbTextCompare) = 0 And _
InStr(1, fldRep.Name, "Gen_", vbTextCompare) = 0 Then
'***** Field definition
Set fldNew = tblNew.CreateField(fldRep.Name, fldRep.Type, _
fldRep.Size)
' Set properties.
On Error Resume Next
fldNew.Attributes = fldRep.Attributes
fldNew.AllowZeroLength = fldRep.AllowZeroLength
fldNew.DefaultValue = fldRep.DefaultValue
fldNew.Required = fldRep.Required
fldNew.Size = fldRep.Size
' Append the field.
tblNew.Fields.Append fldNew
'On Error GoTo Err_NewShell
End If
Next fldRep
'***** Index definition
' Loop through the collection of indexes.
For Each idxRep In tblRep.Indexes
' Ignore replication-related indexes:
' s_Generation, s_GUID
If InStr(1, idxRep.Name, "s_", vbTextCompare) = 0 Then
' Ignore indices set as part of Relation Objects
If Not idxRep.Foreign Then
' Create an index with the same name.
Set idxNew = tblNew.CreateIndex(idxRep.Name)
' Set properties.
idxNew.Clustered = idxRep.Clustered
idxNew.IgnoreNulls = idxRep.IgnoreNulls
idxNew.Primary = idxRep.Primary
idxNew.Required = idxRep.Required
idxNew.Unique = idxRep.Unique
' Loop through the collection of index fields.
For Each fldRep In idxRep.Fields
' Create an index field with the same name.
Set fldNew = idxNew.CreateField(fldRep.Name)
' Set properties.
fldNew.Attributes = fldRep.Attributes
' Append the index field.
idxNew.Fields.Append fldNew
Next fldRep
' Append the index to the table.
tblNew.Indexes.Append idxNew
End If
End If
Next idxRep
' Append the table.
dbNew.TableDefs.Append tblNew
End If
Next tblRep

Following sub will export all table name, field name, type, required , default value to an excel sheet
Sub TableDef()
Dim def As TableDef
Dim wb As Object
Dim xL As Object
Dim lngRow As Long
Dim f As Field
Set xL = CreateObject("Excel.Application")
xL.Visible = True
Set wb = xL.workbooks.Add
lngRow = 2
For Each def In CurrentDb.TableDefs
For Each f In def.Fields
With wb.sheets("Sheet1")
.Range("A" & lngRow).Value = def.Name
.Range("B" & lngRow).Value = f.Name
.Range("C" & lngRow).Value = f.Type
.Range("D" & lngRow).Value = f.Size
.Range("E" & lngRow).Value = f.Required
.Range("F" & lngRow).Value = f.DefaultValue
lngRow = lngRow + 1
End With
Next
Next
End Sub

Related

Getting an error when trying to read all rows of a recordset

I created a query separately and now want to use VBA to read its records and then send certain fields of all rows in an email.
I am currently stuck on trying to extract all the rows from the recordset. I know how to do it for one record, but not with a dynamic recordset. Every week, the recordset could potentially have 1-10 (approx.) records. I had hoped to do this by dynamically reading all rows, saving the fields that I want into variables, and then adding that to the email body, but I arrived at an error.
I'm getting an error that says: Run-time error '3265': Item not found in this collection.
Does anyone know how to fix this error and how I can put all resulting rows of the recordset into the email body?
The code:
Private Sub Form_Timer()
'current_date variable instantiated in a module elsewhere
current_date = Date
'Using the Date function to run every Monday, regardless of the time of day
If current_date = (Date - (DatePart("w", Date, 2, 1) - 1)) Then
'MsgBox ("the current_date variable holds: " & current_date)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim varRecords As Variant
Dim intNumReturned As Integer
Dim intNumColumns As Integer
Dim intColumn As Integer
Dim intRow As Integer
Dim strSQL As String
Dim rst_jobnumber As String
Dim rst_bfloc As String
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_BMBFLoc")
Set rst = qdf.OpenRecordset
If rst.EOF Then
MsgBox "Null."
Else
'Found this part of the code online and not sure if I'm using it right.
varRecords = rst!GetRows(3)
intNumReturned = UBound(varRecords, 2) + 1
intNumColumns = UBound(varRecords, 1) + 1
For intRow = 0 To intNumReturned - 1
For intColumn = 0 To intNumColumns - 1
Debug.Print varRecords(intColumn, intRow)
Next intColumn
Next intRow
'End of code found online.
'rst.MoveFirst 'commenting this out because this query could potentially return multiple rows
rst_jobnumber = rst!job & "-" & rst!suffix
rst_bfloc = rst!Uf_BackflushLoc
rst.Close
dbs.Close
Set rst = Nothing
Set dbs = Nothing
'Dim oApp As Outlook.Application
'Dim oMail As MailItem
'Set oApp = CreateObject("Outlook.application")
'mail_body = "The following jobs do not have the special BF location set in Job Orders: " & rst_
'Set oMail = oApp.CreateItem(olMailItem)
'oMail.Body = mail_body
'oMail.Subject = "Blow Molding Jobs Missing BF Location"
'oMail.To = "something#something.com" 'in the future, create a function that finds all of the SC users' emails from their Windows user
'oMail.Send
'Set oMail = Nothing
'Set oApp = Nothing
End If
End If
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Try working with this code and see how it works for you. I was unsure if you were sending one email per or one email listing all (I assumed the latter)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strMessageBody As String
Set dbs = CurrentDb
Set rst = CurrentDb.OpenRecordset("qry_BMBFLoc")
strMessageBody = "The following jobs do not have the special BF location set in Job Orders: "
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
strMessageBody = strMessageBody & rst!job & "-" & rst!suffix & ","
rst.MoveNext
Loop
If Right(strMessageBody, 1) = "," Then strMessageBody = Left(strMessageBody, Len(strMessageBody)-1)
End If
rst.Close
Set rst = Nothing
Set dbs = Nothing
EDIT - not using dot operator
Replace
varRecords = rst!GetRows(3)
with
varRecords = rst.GetRows(3)
Do you have three rows in your recordset?
If not rst!GetRows(3) will return false - and then next line will fail when you try to use UBound.
A good example of how to implement GetRows
Another possibility is if you're trying to access a Field that's not in your recordset on a line that has rst!

When creating new table and field in vba Access 2000. Getting Error Data Type Conversion Error

I am trying to create a new table with a few field on vba for Access 2000. I am able to create the table and a field when the data type of the field is Text But i need it to be Number. when I am changing the data type from Text to Number it gives me the error Data Type Conversion Error. Any Help would be Appreciated. Thanks
Public Sub CreateNewDB()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
'Initialize the Contractor table
Set db = CurrentDb()
Set tdf = db.CreateTableDef("new test table")
'Specify the fields
With tdf
'Create Sequence No Fied
' Set fld = .CreateField("Sequence No", dbText, 10) ' This works
Set fld = .CreateField("Sequence No", dbNumber, Long INteger) ' this gives me an error
.Fields.Append fld
End With
'save the table
db.TableDefs.Append tdf
Set fld = Nothing
Set tdf = Nothing
End Sub
try dbLong instead of dbNumber. Reference
Here's code to set the PK on a newly created table:
Set td = CurrentDb.CreateTableDef(sLocalTableName, dbAttachSavePWD, sRemoteTableName, sConnect)
CurrentDb.TableDefs.Append td
sExec = "CREATE UNIQUE INDEX PK ON [" & sLocalTableName & "]"
For iPK = 0 To iPkfldCount - 1
sPKfields = sPKfields & "[" & CurrentDb.TableDefs(sLocalTableName).Fields(iPK).Name & "],"
Next
sPKfields = Left(sPKfields, Len(sPKfields) - 1) ' strip trailing comma
CurrentDb.Execute sExec & " (" & sPKfields & ")"
after you set the PK fields, you shouldn't need to index or set to No Duplicates. All PKs work that way.

How to search a field in a table in Access

Using VBA, how can I search for a text string, for example "CHIR", in a table called "ServiceYES", in the field "Service".
After that, I would like to save the neighboring field for all the rows that "CHIR" exists in the table "ServicesYES". The "ServiceYES" table is below:
I basically, want to find all the "CHIR" in "Service" column and then save the names which are on the left of the CHIR, eg "FRANKL_L", "SANTIA_D" as an array.
Thanks for all your help in advance.
Start by creating a SELECT query.
SELECT Code_Perso
FROM ServicesYES
WHERE Service = 'CHIR';
Use SELECT DISTINCT Code_Perso if you want only the unique values.
Add ORDER BY Code_Perso if you care to have them sorted alphabetically.
Once you have a satisfactory query, open a DAO recordset based on that query, and loop through the Code_Perso values it returns.
You don't need to load them directly into your final array. It might be easier to add them to a comma-separated string. Afterward you can use the Split() function (assuming you have Access version >= 2000) to create your array.
Here's sample code to get you started. It's mostly standard boiler-plate, but it might actually work ... once you give it "yourquery".
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strItems As String
Dim varItems As Variant
Set db = CurrentDb
Set rs = db.OpenRecordset("yourquery", dbOpenSnapshot)
With rs
Do While Not .EOF
strItems = strItems & "," & !Code_Perso
.MoveNext
Loop
.Close
End With
If Len(strItems) > 0 Then
' discard leading comma '
strItems = Mid(strItems, 2)
varItems = Split(strItems, ",")
Else
MsgBox "Oops. No matching rows found."
End If
Set rs = Nothing
Set db = Nothing
I tested this and it seems to work. This function will pull all records where ServiceYes='CHIR' and dump the Code_Person value into an array which it will return:
Function x() As String()
Dim rst As Recordset
Set rst = CurrentDb.OpenRecordset( _
"Select * from ServiceYES where Service='CHIR'")
Dim Arr() As String
Dim i As Integer
While rst.EOF = False
ReDim Preserve Arr(i)
Arr(i) = rst.Fields("Code_Person")
i = i + 1
rst.MoveNext
Wend
x = Arr
End Function
Sample Usage:
Debug.Print x()(0)
Paolo,
Here is something I threw together in a few minutes. You can add it to the VBA editor in a module. It uses a trick to get the RecordCount property to behave properly. As for returing the array, you can update the function and create a calling routine. If you need that bit of code, just post a comment.
Thanks!
Option Compare Database
Function QueryServiceYES()
Dim db As Database
Dim saveItems() As String
Set db = CurrentDb
Dim rs As DAO.Recordset
Set rs = db.OpenRecordset("SELECT Code_Perso, Service, Favorites " & _
"FROM ServiceYES " & _
"WHERE Service = 'CHIR'")
'bug in recordset, MoveFirst, then MoveLast forces correct invalid "RecordCount"
rs.MoveLast
rs.MoveFirst
ReDim Preserve saveItems(rs.RecordCount) As String
For i = 0 To rs.RecordCount - 1
saveItems(i) = rs.Fields("Code_Perso")
rs.MoveNext
Next i
'print them out
For i = 0 To UBound(saveItems) - 1
Debug.Print saveItems(i)
Next i
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Function

How do you overwrite a table created in VBA?

I'm creating a table in VBA within a loop and when I run the code a table is created.
But the next time I run it, an error comes up telling me that the table exists and the remainder of the code is not executed.
How can I have it overwrite the existing table (from the previous run)?
Here is my code:
Option Compare Database
Public Function createTables()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim strSQL As String
strSQL = "Select SKUS from SKUS"
Set db = CurrentDb()
Set rst = db.OpenRecordset(strSQL)
Set fld = rst.Fields("SKUS")
'MsgBox fld.Value
rst.MoveFirst
Do While Not rst.EOF
Set tdf = db.CreateTableDef(fld.Value)
Set fld = tdf.CreateField("SKUS", dbText, 30)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Count", dbInteger)
tdf.Fields.Append fld
db.TableDefs.Append tdf
rst.MoveNext
Loop
End Function
Can anyone help me out please?
Thanks!
I would simply delete the table before attempting to recreate it:
db.TableDefs.Delete fld.Value
You can check if the table exists with the following function.
Public Function TableExists(TabName As String) As Boolean
Dim db As DAO.Database
Dim Sdummy As String
Set db = CurrentDb()
On Error Resume Next
Sdummy = db.TableDefs(TabName).Name
TableExists = (Err.Number = 0)
End Function
If the function returns true, then issue following sql statement:
DROP TABLE SKUS
The usual method is to test then delete temp table, requiring more code and recordkeeping for calling procedures that run multiple maketables.
Here is a procedure that is all inclusive, gleaning the source table name from maketable, then deleting before recreating. Also returns number of new records.
Public Function fcnMakeTableForce(strMTQuery As String) As Integer
On Error GoTo ErrorExit
'Runs maketable, deleting the resulting temp table contained in the query (if it
'exists) beforehand. Also returns the number of records in new temp table
Dim dbs As Database
Dim strSQL As String
Set dbs = CurrentDb
'Get SQL from MakeTable
strSQL = dbs.QueryDefs(strMTQuery).sql
'Get target table from SQL:
intINTOPos = InStr(strSQL, "INTO [") + 5
intFROMPos = InStr(strSQL, "FROM [") - 3
strTargetTable = Mid(strSQL, intINTOPos + 1, intFROMPos - intINTOPos - 1)
'Clear target table if it exists
If (DCount("*", "MSysObjects", "[Name] = """ & strTargetTable & """")) > 0 Then
CurrentDb.TableDefs.Delete (strTargetTable)
End If
dbs.Execute strMTQuery
intRecordsAdded = DCount("*", strTargetTable)
fcnMakeTableForce = intRecordsAdded
NormalExit:
Exit Function
ErrorExit:
MsgBox "Error: " & Err.Description & vbCr & vbCr & "in Function: fcnMakeTableForce"
Resume NormalExit
End Function

How to copy a linked table to a local table in Ms Access programmatically?

So I'd like to copy a linked table to a local one in code, structure and data in MS Access 2003.
Code being : VBA or C#. Or anything else for that matter..
UPDATE : I want the copy structure and data behaviour from ms access to keep the Primary Keys. If you copy a linked table, you can choose to paste it as 'structure and data (local table)'
It is that I want to achieve in code.
My understanding is that DAO does not support the decimal data type, but ADOX does. Here's an updated procedure that uses ADOX instead to copy the schema to a new table.
One interesting item of note: The OLEDB provider for Jet sorts the columns alphabetically rather than by ordinal position as explained in this KB article. I wasn't concerned about preserving the ordinal position, but you may be, in which case you can update this procedure to meet your needs.
In order for the ADOX version of the code to work, you'll need to set a reference to Microsoft ADO Ext. 2.x for DDL and Security (where x = version number; I used 2.8 to test this procedure). You'll also need a reference to ADO as well.
Public Sub CopySchemaAndData_ADOX(ByVal sourceTableName As String, ByVal destinationTableName As String)
On Error GoTo Err_Handler
Dim cn As ADODB.Connection
Dim cat As ADOX.Catalog
Dim sourceTable As ADOX.Table
Dim destinationTable As ADOX.Table
Set cn = CurrentProject.Connection
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = cn
Set destinationTable = New ADOX.Table
destinationTable.Name = destinationTableName
Set sourceTable = cat.Tables(sourceTableName)
Dim col As ADOX.Column
For Each col In sourceTable.Columns
Dim newCol As ADOX.Column
Set newCol = New ADOX.Column
With newCol
.Name = col.Name
.Attributes = col.Attributes
.DefinedSize = col.DefinedSize
.NumericScale = col.NumericScale
.Precision = col.Precision
.Type = col.Type
End With
destinationTable.Columns.Append newCol
Next col
Dim key As ADOX.key
Dim newKey As ADOX.key
Dim KeyCol As ADOX.Column
Dim newKeyCol As ADOX.Column
For Each key In sourceTable.Keys
Set newKey = New ADOX.key
newKey.Name = key.Name
For Each KeyCol In key.Columns
Set newKeyCol = destinationTable.Columns(KeyCol.Name)
newKey.Columns.Append (newKeyCol)
Next KeyCol
destinationTable.Keys.Append newKey
Next key
cat.Tables.Append destinationTable
'Finally, copy data from source to destination table
Dim sql As String
sql = "INSERT INTO " & destinationTableName & " SELECT * FROM " & sourceTableName
CurrentDb.Execute sql
Err_Handler:
Set cat = Nothing
Set key = Nothing
Set col = Nothing
Set sourceTable = Nothing
Set destinationTable = Nothing
Set cn = Nothing
If Err.Number <> 0 Then
MsgBox Err.Number & ": " & Err.Description, vbCritical, Err.Source
End If
End Sub
Here's the original DAO procedure
Public Sub CopySchemaAndData_DAO(SourceTable As String, DestinationTable As String)
On Error GoTo Err_Handler
Dim tblSource As DAO.TableDef
Dim fld As DAO.Field
Dim db As DAO.Database
Set db = CurrentDb
Set tblSource = db.TableDefs(SourceTable)
Dim tblDest As DAO.TableDef
Set tblDest = db.CreateTableDef(DestinationTable)
'Iterate over source table fields and add to new table
For Each fld In tblSource.Fields
Dim destField As DAO.Field
Set destField = tblDest.CreateField(fld.Name, fld.Type, fld.Size)
If fld.Type = 10 Then
'text, allow zero length
destField.AllowZeroLength = True
End If
tblDest.Fields.Append destField
Next fld
'Handle Indexes
Dim idx As Index
Dim iIndex As Integer
For iIndex = 0 To tblSource.Indexes.Count - 1
Set idx = tblSource.Indexes(iIndex)
Dim newIndex As Index
Set newIndex = tblDest.CreateIndex(idx.Name)
With newIndex
.Unique = idx.Unique
.Primary = idx.Primary
'Some Indexes are made up of more than one field
Dim iIdxFldCount As Integer
For iIdxFldCount = 0 To idx.Fields.Count - 1
.Fields.Append .CreateField(idx.Fields(iIdxFldCount).Name)
Next iIdxFldCount
End With
tblDest.Indexes.Append newIndex
Next iIndex
db.TableDefs.Append tblDest
'Finally, copy data from source to destination table
Dim sql As String
sql = "INSERT INTO " & DestinationTable & " SELECT * FROM " & SourceTable
db.Execute sql
Err_Handler:
Set fld = Nothing
Set destField = Nothing
Set tblDest = Nothing
Set tblSource = Nothing
Set db = Nothing
If Err.Number <> 0 Then
MsgBox Err.Number & ": " & Err.Description, vbCritical, Err.Source
End If
End Sub
try docmd.CopyObject or docmd.TransferDatabase
Create this query and execute it
SELECT * INTO MyNewTable FROM LinkedTableName
In VBA you can do
docmd.runsql "SELECT * INTO MyNewTable FROM LinkedTableName"
To keep the structure you would have to do DoCmd.TransferDatabase acImport