I've created the following code which I want to use in the future to get a list of all the fields in a table:
Private Sub btnGetFields_Click()
Dim myDBS As Database
Dim fldLoop As Fields
Dim fld As Field
Dim relLoop As Relation
Dim tdfloop As TableDef
Set myDBS = CurrentDb
With myDBS
' Display the attributes of a TableDef object's
' fields.
Debug.Print "Attributes of fields in " & _
.TableDefs("ALT_IDENTIFIER").Name & " table:"
'Error occurs in line below
Set fldLoop = .TableDefs("ALT_IDENTIFIER").Fields
For Each fld In fldLoop
Debug.Print " " & fld.Name & " = " & _
fld.Attributes
Next fld
.Close
End With
End Sub
But I'm getting a Type Mistmatch - Runtime Error 13 back when I run the code.
Why? fldloop is a Fields object - i.e. a collection of field objects right? which is what the TableDefs.Fields procedure returns so why am I getting this error?
Thanks
I was having same issue and i resolved it by changing "Field" to "DAO.Field":
Dim fld As DAO.Field
Maybe it helps another one.
Best regards
Sometimes passing values to their literal types in Access causes these kinds of errors, not sure why, a quick fix is usually to dimension your variable as an open data type instead e.g:
Dim fldloop as object
Otherwise you could re-write this line:
For Each fld In fldLoop
to
For Each fld In .TableDefs("ALT_IDENTIFIER").Fields
and forget dimensioning a separate variable all together
UPDATE:
Perhaps this would be more useful for SQL Server, if you only have access via MS Access then you should be able to use this example by looping through your linked tables and dynamically re-building a a Pass Through Query
What is the equivalent of 'describe table' in SQL Server?
Found the problem: the reason I was getting the error was because I wasn't referring to the exact field. Though I'm still unsure as to why an error was thrown on a Fields object that was assigned a Fields value.
Here's the code:
Dim f As Field
Dim fldTableDef As Field
Dim Rst As DAO.Recordset
Dim numField As Integer
Dim linkedTable As String
linkedTable = "ALT_IDENTIFIER"
Set Rst = CurrentDb.OpenRecordset(linkedTable)
numField = Rst.Fields.Count
'Loop through
Dim index As Integer
For index = 0 To numField - 1
If Rst.Fields(index).Type = dbDate Then
Debug.Print "Field: " & Rst.Fields(index).Name; " = Date/Time" & Rst.Fields(index).Value
End If
Next
Related
I'm attempting to create a macro that based on a user input (on an excel sheet) will pull data from a query I made in Access. In order for it to pull only the applicable lines (rows) of data it needs to edit the WHERE statement accordingly. I have adapted the following code from a previous question but I am running into issues when I try to replace the SQL.
Private Sub CommandButton4_Click()
Const DbLoc As String = "MYfilepath"
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim wb1 As Workbook, ws1 As Worksheet, ws2 As Worksheet, SQL As String, recCount As Long
Set wb1 = Workbooks("mytool.xlsm")
Set ws1 = wb1.Sheets("Inputs")
Set ws2 = wb1.Sheets("raw")
Set db = OpenDatabase(DbLoc)
Set userinput = ws1.Range("D6")
SQL = "SELECT Dock_Rec_Problems.Merch_Name, Dock_Rec_Problems.Vendor_Error_Code, Dock_Rec_Problems.DC, Dock_Rec_Problems.Vendor_ID_IP, Dock_Rec_Problems.Vendor_Name, Dock_Rec_Problems.PO_Number, Dock_Rec_Problems.SKU_No, Dock_Rec_Problems.Item_Description, Dock_Rec_Problems.Casepack, Dock_Rec_Problems.Retail, Dock_Rec_Problems.Num_Of_Cases, Dock_Rec_Problems.Dock_Rec_Problems_DGID"
SQL = SQL & "FROM Dock_Rec_Problems;"
SQL = SQL & "WHERE [Dock_Rec_Problems_DGID] =" & userinput
Set rs = db.OpenRecordset(SQL, dbOpenSnapshot)
If rs.RecordCount = 0 Then
MsgBox "Not found in database", vbInformation + vbOKOnly, "No Data"
GoTo SubExit
End If
ws2.Range("A1").CopyFromRecordset rs
SubExit:
On Error Resume Next
Application.Cursor = xlDefault
rs.Close
Set rs = Nothing
Exit Sub
End Sub
Let me know if there is anything I can clear up...thanks!
Original Query SQL
SELECT Dock_Rec_Problems.Merch_Name, Dock_Rec_Problems.Vendor_Error_Code,
Dock_Rec_Problems.DC, Dock_Rec_Problems.Vendor_ID_IP,
Dock_Rec_Problems.Vendor_Name, Dock_Rec_Problems.PO_Number,
Dock_Rec_Problems.SKU_No, Dock_Rec_Problems.Item_Description,
Dock_Rec_Problems.Casepack, Dock_Rec_Problems.Retail,
Dock_Rec_Problems.Num_Of_Cases, Dock_Rec_Problems.Dock_Rec_Problems_DGID
FROM Dock_Rec_Problems;
Single input SQL
SELECT Dock_Rec_Problems.Merch_Name, Dock_Rec_Problems.Vendor_Error_Code, Dock_Rec_Problems.DC, Dock_Rec_Problems.Vendor_ID_IP, Dock_Rec_Problems.Vendor_Name, Dock_Rec_Problems.PO_Number, Dock_Rec_Problems.SKU_No, Dock_Rec_Problems.Item_Description, Dock_Rec_Problems.Casepack, Dock_Rec_Problems.Retail, Dock_Rec_Problems.Num_Of_Cases, Dock_Rec_Problems.Dock_Rec_Problems_DGID
FROM Dock_Rec_Problems
WHERE (((Dock_Rec_Problems.Dock_Rec_Problems_DGID)="D040323000"));
Double input SQL
SELECT Dock_Rec_Problems.Merch_Name, Dock_Rec_Problems.Vendor_Error_Code, Dock_Rec_Problems.DC, Dock_Rec_Problems.Vendor_ID_IP, Dock_Rec_Problems.Vendor_Name, Dock_Rec_Problems.PO_Number, Dock_Rec_Problems.SKU_No, Dock_Rec_Problems.Item_Description, Dock_Rec_Problems.Casepack, Dock_Rec_Problems.Retail, Dock_Rec_Problems.Num_Of_Cases, Dock_Rec_Problems.Dock_Rec_Problems_DGID
FROM Dock_Rec_Problems
WHERE (((Dock_Rec_Problems.Dock_Rec_Problems_DGID)="D040323000")) OR (((Dock_Rec_Problems.Dock_Rec_Problems_DGID)="D040323012"));
Because the size of your user input is open-ended, consider using a temp table saved in MS Access with exact structure as your query (can be built with: SELECT * INTO temp_table FROM myquery). Then, with each call of the Excel macro:
Clean the temp table out with DELETE.
Iterate through the user input Excel range of cells to append needed rows to table with INSERT INTO...SELECT.
Create recordset from temp table.
And once again, here is a prime use case for SQL parameterization especially since the query receives user input. A clever, malicious user can potentially clean out your database! But at the very least, code is arguably more maintainable. Because you are using DAO, consider QueryDefs to bind parameter value to a prepared, saved query and then bind into a recordset.
SQL (save as an MS Access stored action query)
PARAMETERS [userparam] TEXT(255);
INSERT INTO Excel_Table (Merch_Name, Vendor_Error_Code, DC, Vendor_ID_IP,
Vendor_Name, PO_Number, SKU_No, Item_Description,
Casepack, Retail, Num_Of_Cases, Dock_Rec_Problems_DGID)
SELECT d.Merch_Name, d.Vendor_Error_Code, d.DC, d.Vendor_ID_IP,
d.Vendor_Name, d.PO_Number, d.SKU_No, d.Item_Description,
d.Casepack, d.Retail, d.Num_Of_Cases, d.Dock_Rec_Problems_DGID
FROM Dock_Rec_Problems d
WHERE d.[Dock_Rec_Problems_DGID] = [userparam];
VBA
...
Dim qdef As DAO.QueryDef
Dim cel As Range
Set qdef = db.QueryDefs("mySavedQuery")
' CLEAN OUT TEMP EXCEL TABLE
db.Execute "DELETE FROM Excel_Table"
' ITERATIVELY APPEND TO EXCEL TABLES
For Each cel In userinput.Cells
qdef!userparam = cel.Value ' BIND PARAM
qdef.Execute dbFailOnError ' EXECUTE ACTION
Next cel
' OPEN RECORDSET TO TABLE
Set rs = db.OpenRecordset("Excel_Table", dbOpenSnapshot)
If rs.RecordCount = 0 Then
MsgBox "Recieving problem not found in database", vbInformation+vbOKOnly, "No Data"
GoTo SubExit
End If
ws2.Range("A1").CopyFromRecordset rs
.......
There are a few problems with the code you've displayed. For instance, the strNewFields variable is attempted to be used, before you've set it to anything, here:
strNewSQL = strNewSQL & Replace(WHERE_FIELDS, "<INSERT FIELDS>", strNewFields)
At this point strNewFields is totally blank, but you're trying to do a replace.
I would suggest:
Change you WHERE_FIELDS Const from
Const WHERE_FIELDS As String = "WHERE " _
& "(((Dock_Rec_Problems.Dock_Rec_Problems_DGID) = <INSERT FIELDS>)); "
to
Const WHERE_FIELDS As String = "WHERE " _
& " [Dock_Rec_Problems].[Dock_Rec_Problems_DGID] IN (<INSERT FIELDS>); "
I find this easier to read then all the nested brackets, it removes the equals sign in preference of the IN() statement.
Now you want to populate the strNewFields variable with whatever inputs they gave you. Probably using a Do While Loop to iterate through the INPUTS. Each input is added to the strNewFields variable something like this.
Dim rs as Recordset
Set RS = currentdb.mydataset ' You need to modify this line
rs.Open
strNewFields = strNewFields & "'" & rs("InputFieldName") & "'"
rs.MoveNext
Do While rs.EOF = False
strNewFields = strNewFields & ",'" & rs("InputFieldName") & "'"
Loop
strNewFields = StrNewFields & ")"
Now that you have strNewFields populated you can simply run your replace()
Replace(WHERE_FIELDS, "<INSERT FIELDS>", strNewFields)
You need to look at the order in which you are setting variables though, as pointed out above, you've got some order of event issues.
Michael
I've been struggling all afternoon to write a function that will cache the displayed records in a form datasheet to a temporary table.
The use-case is that the user uses the datasheet auto-filters & sorting to get the records into their desired form. Then they're running a report function that outputs what they see as xml, runs it through an xslt transform to html. I can't get MSXML working direct from queries, hence the need for a local cached copy of what the user sees in the form datasheet.
What I have so far works, but seemingly ignores the filter & order by clauses in the sql string.
Private Sub CacheLocalTemp()
Dim strSql As String: strSql = "SELECT * INTO rpt_TEMP FROM tbl_Outputs"
If Len(Me.Filter) > 0 Then
strSql = strSql & " WHERE " & Me.Filter
End If
If Len(Me.OrderBy) > 0 Then
strSql = strSql & " ORDER BY " & Me.OrderBy
End If
DoCmd.SetWarnings False
DoCmd.RunSQL strSql
DoCmd.SetWarnings True
End Sub
I've seen methods using INSERT and SELECT INTO VALUES (x, y z), but didn't want to go down this route as it would mean I need to hard-code all field names, and there are a lot over about 10 different forms.
All the code I'm finding is long-winded / excessive, and I am astounded there isn't a more elegant / straight-forward way of just dumping a snapshot copy of what is displayed in the datasheet straight into its own table.
Any help would be much appreciated. Thanks.
You can solve this problem pretty easily by using a helper function that outputs a recordset to a table.
Helper function:
Public Sub RecordSetToTable(rs As DAO.Recordset, tableName As String)
Dim td As DAO.TableDef
Set td = CurrentDb.CreateTableDef(tableName)
Dim fld As DAO.Field
For Each fld In rs.Fields
td.Fields.Append td.CreateField(fld.Name, fld.Type, fld.Size)
Next
CurrentDb.TableDefs.Append td
Dim tableRS As DAO.Recordset
Set tableRS = CurrentDb.OpenRecordset(tableName)
rs.MoveFirst
Do While Not rs.EOF
tableRS.AddNew
For Each fld In rs.Fields
tableRS.Fields(fld.Name).Value = fld.Value
Next
tableRS.Update
rs.MoveNext
Loop
End Sub
On the form:
Private Sub CacheLocalTemp()
RecordSetToTable Me.Recordset, "rpt_TEMP"
End Sub
No messing around with constructing queries, ordering, etc. Just write the recordset straight to a new table.
I would like to create a program in Excel that loops through a list of Access databases and writes the VBA that exists in the Access modules. I have found some code that I can run from Access which writes the VBA that exists in the Access modules. I am trying to figure out how to reference the database files from Excel and run the program on each database file. I will probably be able to figure out how to loop through the database files. I just need help with referencing the database file in the below code.
I can open the database with something like this:
Dim cstrDbFile As String = "C:\Database51.accdb"
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
objShell.Run cstrDbFile
I also tried to set up a reference to Access like this:
Dim appAccess As Object
Set appAccess = CreateObject("Access.Application")
appAccess.OpenCurrentDatabase ("C:\Database51.accdb")
I need to figure out how to refer to the Access database in:
Application.VBE.ActiveVBProject.VBComponents
I probably need to figure out how to create a reference to replace ActiveVBProject.
Below is some code I found which writes the contents of VBA modules. I don't remember where I found it.
For Each Component In Application.VBE.ActiveVBProject.VBComponents
With Component.CodeModule
'The Declarations
For Index = 1 To .CountOfDeclarationLines
Debug.Print .Lines(Index, 1)
Next Index
'The Procedures
For Index = .CountOfDeclarationLines + 1 To .CountOfLines
Debug.Print .Lines(Index, 1)
Next Index
End With
Next Component
The following code will let you see Access database objects, but I don't know how to export the code (DoCmd not in Excel?). Your task would be VERY simple to do from Access, so I would reconsider...
Option Explicit
' Add a reference to the DAO Object Library
Sub Read_Access_VBA()
Dim dbs As DAO.Database
Dim ctr As DAO.Container
Dim doc As DAO.Document
Dim iC As Integer
Dim iD As Integer
Dim i As Integer
Dim mdl As Module
Set dbs = DBEngine.OpenDatabase("c:\TEMP\106thRoster.mdb", False, False, _
"MS Access;")
Debug.Print "----------------------------------------"
For iC = 0 To dbs.Containers.Count - 1
Debug.Print "Container: " & dbs.Containers(iC).Name
If dbs.Containers(iC).Documents.Count > 0 Then
For iD = 0 To dbs.Containers(iC).Documents.Count - 1
Debug.Print vbTab & "Doc: " & dbs.Containers(iC).Documents(iD).Name
Next iD
Else
Debug.Print " No Documents..."
End If
Next iC
'Set ctr = dbs.Containers!Modules
dbs.Close
Set doc = Nothing
Set ctr = Nothing
Set dbs = Nothing
End Sub
I was able to find some code that will assist me with my final goal: Exporting MS Access Forms and Class / Modules Recursively to text files?
Below are the most significant lines that will allow me to make progress with the project.
LineCount = oApp.Forms(Name).Module.CountOfLines
FileName = Path & "\" & Name & ".vba"
F = FreeFile
Open FileName For Output Access Write As #F
Print #F, oApp.Forms(Name).Module.Lines(1, LineCount)
Close #F
I've written some VBA:
For x = LBound(resProdID) To UBound(resProdID)
CurrentDb.QueryDefs("qry_findID_vba").SQL = "" & _
"SELECT tbl_products.ProdID " & _
"FROM tbl_products " & _
"WHERE (tbl_products.Size = " & resSize(x) & " " & _
"AND tbl_products.SupplID = '" & Forms.frm_suppliers.SupplID & "')"
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset("qry_findID_vba")
MsgBox rst.RecordCount
If rst.RecordCount <> 0 Then
rst.MoveLast
rst.MoveFirst
newProdID(x) = rst.Fields(0).Value
MsgBox "This never fires"
End If
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
Next x
What happens when I run it, is that a box pops up saying 0. I click Ok, and it repeats one more time. This is because I have two items in my resProdID-array.
However, if I open the query "qry_findID_vba" normally, it shows one row, like I expected.
Why doesn't VBA return this row? Have I done anything wrong?
Does this code messagebox the correct count? Can you use it instead?
(Note, I haven't actually run it, so watch out for slight syntax errors.)
For x = LBound(resProdID) To UBound(resProdID)
Dim sql as String
Dim rst As DAO.Recordset
sql = "Select tbl_products.ProdID FROM tbl_products " & _
"WHERE (tbl_products.Size = " & resSize(x) & " " & _
"AND tbl_products.SupplID = '" & Forms.frm_suppliers.SupplID & "')"
Set rst = dbs.OpenRecordset(sql)
if not rst.eof then
MsgBox rst.fields("ProdID")
else
Msgbox "None found!"
end if
rst.Close
Set rst = Nothing
Next x
Also, try copying everything to a new form, and compacting and repairing the database ...
First off, you really should use QueryDef parameters. They provide a number of benefits:
A safety net against malformed input and SQL injection.
You don't need to redefine the query SQL text every time a parameter value changes.
They make your VBA independent of the query text. This is a simple query, but more complex ones benefit if you don't have to change your VBA code just to change the SQL.
They provide type safety - you can use typed variables in VBA and be sure that the query cannot fail with data type errors.
They can be re-used - parameterized queries can be bound to forms, or executed directly, for example.
Last but not least, it looks much nicer and clearer when used in VBA.
Your situation is exactly what parameterized QueryDefs are for.
Change the query text of qry_findID_vba in Access to:
PARAMETERS [ProductSize] Text (255), [SupplID] Number;
SELECT ProdID
FROM tbl_products
WHERE [tbl_products].[Size] = [ProductSize] AND [tbl_products].[SupplID] = [SupplID];
Replace the parameter data types according to your actual data types in the table.
Next, when you're in a loop, don't re-define fixed variables again and again. dbs and rst don't need to be defined inside the loop at all.
Last point, the RecordCount property does not work the way you think. Quote from the docs, emphasis mine:
Use the RecordCount property to find out how many records in a
Recordset or TableDef object have been accessed. The RecordCount
property doesn't indicate how many records are contained in a
dynaset–, snapshot–, or forward–only–type Recordset object until all
records have been accessed.
[...]
To force the last record to be accessed, use the MoveLast method on the Recordset object.
Instead of calling MoveLast, you can also check the .EOF property. If it is false, at least one record is available.
For one-off query results like this one, I would recommend using the snapshot type Recordset. You can define which type you want to use when you call OpenRecordset on the QueryDef.
Now:
Dim qry_findID_vba As DAO.QueryDef
Set qry_findID_vba = CurrentDb().QueryDefs("qry_findID_vba")
qry_findID_vba.Parameters("SupplID") = Forms.frm_suppliers.SupplID
For x = LBound(resProdID) To UBound(resProdID)
qry_findID_vba.Parameters("ProductSize") = resSize(x)
With qry_findID_vba.OpenRecordset(dbOpenSnapshot)
If Not .EOF Then
newProdID(x) = .Fields("ProdID").Value
End If
End With
Next x
Note that I use With to save maintaining a helper rst variable.
I have a couple of mdb files with the exact table structure. I have to change the primary key of the main table from autonumber to number in all of them, which means I have to:
Drop the all the relationships the main table has
Change the main table
Create the relationships again,... for all the tables.
Is there any way to export the relationships from one file and importing them to all the rest?
I am sure this can be done with some macro/vb code. Does anyone has an example I could use?
Thanks.
Not a complete solution, but this may get you going...
The following function will print out the metadata for all relationships. Change this to save to a file in whatever format you prefer (CSV, tab delimited, XML, etc.):
Function PrintRelationships()
For Each rel In CurrentDb.Relations
With rel
Debug.Print "Name: " & .Name
Debug.Print "Attributes: " & .Attributes
Debug.Print "Table: " & .Table
Debug.Print "ForeignTable: " & .ForeignTable
Debug.Print "Fields:"
For Each fld In .Fields
Debug.Print "Field: " & fld.Name
Next
End With
Next
End Function
This function will drop all the relationships in the database:
Function DropRelationships()
With CurrentDb
For Each rel In .Relations
.Relations.Delete Name:=rel.Name
Next
End With
End Function
This function will create a relationship. You'll have to iterate over the file of saved relationship data.
Function CreateRelationships()
With CurrentDb
Set rel = .CreateRelation(Name:="[rel.Name]", Table:="[rel.Table]", ForeignTable:="[rel.FireignTable]", Attributes:=[rel.Attributes])
rel.Fields.Append rel.CreateField("[fld.Name for relation]")
rel.Fields("[fld.Name for relation]").ForeignName = "[fld.Name for relation]"
.Relations.Append rel
End With
End Function
Error handling and IO omitted due to time constraints (gotta put the kids to bed).
Hope this helps.
Based on #Patrick Cuff's answer, I have created a pair of scripts: one exporting into xml, other reading this xml and parsing it into the database
VBScript for exporting relationships from MsAccess into XML
'supply the Access Application object into this function and path to file to which the output should be written
Function ExportRelationships(oApplication, sExportpath)
Dim relDoc, myObj
Set relDoc = CreateObject("Microsoft.XMLDOM")
relDoc.appendChild relDoc.createElement("Relations") 'create root xml element
'loop though all the relations
For Each myObj In oApplication.CurrentDb.Relations
If Not Left(myObj.Name, 4) = "MSys" Then 'exclude system relations
Dim relName, relAttrib, relTable, relFoTable, fld
relDoc.childNodes(0).appendChild relDoc.createElement("Relation")
Set relName = relDoc.createElement("Name")
relName.Text = myObj.Name
relDoc.childNodes(0).lastChild.appendChild relName
Set relAttrib = relDoc.createElement("Attributes")
relAttrib.Text = myObj.Attributes
relDoc.childNodes(0).lastChild.appendChild relAttrib
Set relTable = relDoc.createElement("Table")
relTable.Text = myObj.Table
relDoc.childNodes(0).lastChild.appendChild relTable
Set relFoTable = relDoc.createElement("ForeignTable")
relFoTable.Text = myObj.ForeignTable
relDoc.childNodes(0).lastChild.appendChild relFoTable
'in case the relationship works with more fields
For Each fld In myObj.Fields
Dim lf, ff
relDoc.childNodes(0).lastChild.appendChild relDoc.createElement("Field")
Set lf = relDoc.createElement("Name")
lf.Text = fld.Name
relDoc.childNodes(0).lastChild.lastChild.appendChild lf
Set ff = relDoc.createElement("ForeignName")
ff.Text = fld.ForeignName
relDoc.childNodes(0).lastChild.lastChild.appendChild ff
Next
End If
Next
relDoc.insertBefore relDoc.createProcessingInstruction("xml","version='1.0'"), relDoc.childNodes(0)
relDoc.Save sExportpath
End Function
VBScript for importing relationships into MsAccess from XML
'supply the Access Application object into this function and path to file from which the input should be read
Function ImportRelationships(oApplication, sImportpath)
Dim relDoc, myObj
Set relDoc = CreateObject("Microsoft.XMLDOM")
relDoc.Load(sImportpath)
Dim xmlRel, xmlField, accessRel, relTable, relName, relFTable, relAttr, i
'loop through every Relation node inside .xml file
For Each xmlRel in relDoc.selectNodes("/Relations/Relation")
relName = xmlRel.selectSingleNode("Name").Text
relTable = xmlRel.selectSingleNode("Table").Text
relFTable = xmlRel.selectSingleNode("ForeignTable").Text
relAttr = xmlRel.selectSingleNode("Attributes").Text
'remove any possible conflicting relations or indexes
On Error Resume next
oApplication.CurrentDb.Relations.Delete (relName)
oApplication.CurrentDb.TableDefs(relTable).Indexes.Delete(relName)
oApplication.CurrentDb.TableDefs(relFTable).Indexes.Delete(relName)
On Error Goto 0
'create the relationship object
Set accessRel = oApplication.CurrentDb.CreateRelation(relName, relTable, relFTable, relAttr)
'in case the relationship works with more fields
For Each xmlField In xmlRel.selectNodes("Field")
accessRel.Fields.Append accessRel.CreateField(xmlField.selectSingleNode("Name").Text)
accessRel.Fields(xmlField.selectSingleNode("Name").Text).ForeignName = xmlField.selectSingleNode("ForeignName").Text
Next
'and finally append the newly created relationship to the database
oApplication.CurrentDb.Relations.Append accessRel
Next
End Function
Notes
Just to clarify what is expected to be passed into oApplication parameter
Set oApplication = CreateObject("Access.Application")
oApplication.NewCurrentDatabase path 'new database
oApplication.OpenCurrentDatabase path 'existing database
In case you are running this from VBA instead of VBScript, you can delete the parameter and just the regular Application object everywhere in the code where oApplication is being used.
I got started to work on this code as I needed to implement a Version Control on a very complicated MsAccess project. This post got me moving, there are also some good advices on how to export/import other parts of the MsAccess project.
It occurs to me that you can use a backup of the file made before any changes to restore the indexes and relations. Here are some notes.
Sub RunExamples()
Dim strCopyMDB As String
Dim fs As FileSystemObject
Dim blnFound As Boolean
Dim i
' This code is not intended for general users, it is sample code built '
' around the OP '
'You will need a reference to the Microsoft DAO 3.x Object Library '
'This line causes an error, but it will run '
'It is not suitable for anything other than saving a little time '
'when setting up a new database '
Application.References.AddFromFile ("C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll")
'You must first create a back-up copy '
Set fs = CreateObject("Scripting.FileSystemObject")
strCopyMDB = CurrentProject.Path & "\c.mdb"
blnFound = fs.FileExists(strCopyMDB)
i = 0
Do While blnFound
strCopyMDB = CurrentProject.Path & "\c" & i & ".mdb"
blnFound = fs.FileExists(strCopyMDB)
Loop
fs.CopyFile CurrentProject.FullName, strCopyMDB
ChangeTables
AddIndexesFromBU strCopyMDB
AddRelationsFromBU strCopyMDB
End Sub
Sub ChangeTables()
Dim db As Database
Dim tdf As DAO.TableDef
Dim rel As DAO.Relation
Dim fld As DAO.Field
Dim ndx As DAO.Index
Dim i
Set db = CurrentDb
'In order to programmatically change an autonumber, '
'it is necessary to delete any relationships that '
'depend on it. '
'When deleting from a collection, it is best '
'to iterate backwards. '
For i = db.Relations.Count - 1 To 0 Step -1
db.Relations.Delete db.Relations(i).Name
Next
'The indexes must also be deleted or the '
'number cannot be changed. '
For Each tdf In db.TableDefs
If Left(tdf.Name, 4) <> "Msys" Then
For i = tdf.Indexes.Count - 1 To 0 Step -1
tdf.Indexes.Delete tdf.Indexes(i).Name
Next
tdf.Indexes.Refresh
For Each fld In tdf.Fields
'If the field is an autonumber, '
'use code supplied by MS to change the type '
If (fld.Attributes And dbAutoIncrField) Then
AlterFieldType tdf.Name, fld.Name, "Long"
End If
Next
End If
Next
End Sub
Sub AddIndexesFromBU(MDBBU)
Dim db As Database
Dim dbBU As Database
Dim tdf As DAO.TableDef
Dim tdfBU As DAO.TableDef
Dim ndx As DAO.Index
Dim ndxBU As DAO.Index
Dim i
Set db = CurrentDb
'This is the back-up made before starting '
Set dbBU = OpenDatabase(MDBBU)
For Each tdfBU In dbBU.TableDefs
'Skip system tables '
If Left(tdfBU.Name, 4) <> "Msys" Then
For i = tdfBU.Indexes.Count - 1 To 0 Step -1
'Get each index from the back-up '
Set ndxBU = tdfBU.Indexes(i)
Set tdf = db.TableDefs(tdfBU.Name)
Set ndx = tdf.CreateIndex(ndxBU.Name)
ndx.Fields = ndxBU.Fields
ndx.IgnoreNulls = ndxBU.IgnoreNulls
ndx.Primary = ndxBU.Primary
ndx.Required = ndxBU.Required
ndx.Unique = ndxBU.Unique
' and add it to the current db '
tdf.Indexes.Append ndx
Next
tdf.Indexes.Refresh
End If
Next
End Sub
Sub AddRelationsFromBU(MDBBU)
Dim db As Database
Dim dbBU As Database
Dim rel As DAO.Relation
Dim fld As DAO.Field
Dim relBU As DAO.Relation
Dim i, j, f
On Error GoTo ErrTrap
Set db = CurrentDb
'The back-up again '
Set dbBU = OpenDatabase(MDBBU)
For i = dbBU.Relations.Count - 1 To 0 Step -1
'Get each relationship from bu '
Set relBU = dbBU.Relations(i)
Debug.Print relBU.Name
Set rel = db.CreateRelation(relBU.Name, relBU.Table, relBU.ForeignTable, relBU.Attributes)
For j = 0 To relBU.Fields.Count - 1
f = relBU.Fields(j).Name
rel.Fields.Append rel.CreateField(f)
rel.Fields(f).ForeignName = relBU.Fields(j).ForeignName
Next
'For some relationships, I am getting error'
'3284 Index already exists, which I will try'
'and track down tomorrow, I hope'
'EDIT: Apparently this is due to Access creating hidden indexes
'and tracking these down would take quite a bit of effort
'more information can be found in this link:
'http://groups.google.ie/group/microsoft.public.access/browse_thread/thread/ca58ce291bdc62df?hl=en&ie=UTF-8&q=create+relation+3284+Index+already+exists
'It is an occasional problem, so I've added an error trap
'Add the relationship to the current db'
db.Relations.Append rel
Next
ExitHere:
Exit Sub
ErrTrap:
If Err.Number = 3284 Then
Debug.Print relBU.Name, relBU.Table, relBU.ForeignTable, relBU.Attributes
Resume Next
Else
'this is not a user sub, so may as well ... '
Stop
End If
End Sub
Sub AlterFieldType(TblName As String, FieldName As String, _
NewDataType As String)
'http://support.microsoft.com/kb/128016'
Dim db As Database
Dim qdf As QueryDef
Set db = CurrentDb()
' Create a dummy QueryDef object.'
Set qdf = db.CreateQueryDef("", "Select * from PROD1")
' Add a temporary field to the table.'
qdf.SQL = "ALTER TABLE [" & TblName & "] ADD COLUMN AlterTempField " & NewDataType
qdf.Execute
' Copy the data from old field into the new field.'
qdf.SQL = "UPDATE DISTINCTROW [" & TblName _
& "] SET AlterTempField = [" & FieldName & "]"
qdf.Execute
' Delete the old field.'
qdf.SQL = "ALTER TABLE [" & TblName & "] DROP COLUMN [" _
& FieldName & "]"
qdf.Execute
' Rename the temporary field to the old field's name.'
db.TableDefs("[" & TblName & "]").Fields("AlterTempField").Name = FieldName
End Sub
Thanks for code snippet.
to get rid of your 3284 error I have changed a few things.
If you copy all indexes from sample mdb and then try to put relationships it throws an exception as it expects no idexes for relationshisps when you put relationships it puts its own indexes.
Steps I followed are (assume target.mdb and source.mdb):
Run this code in target.mdb remove all indexes and relationsships
frmo target.mdb by calling ChangeTables
Call AddIndexesFromBU source.mdb and use condition
If ndxBU.Unique Then tdf.Indexes.Append ndx End If this willput just Unique index
call AddRelationsFromBU source.mdb and put all relationsships
Call again AddIndexesFromBU source.mdb and change condition to If
not ndxBU.Unique Then
I have also added error trap same as AddRelationsFromBU in AddIndexesFromBU and resume next for if ans else
This worked for me.