Relink SQL tables in Access - vba

I have the following code that is supposed to unlink all Access 2003 tables that are listed in one table and link SQL tables, but it gives error: 3265 Item not found in this collection. The table is not empty, I don't know what is the problem.
Sub LinkODBC()
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim connString As String
Dim rs As DAO.Recordset
Set db = CurrentDb()
connString = "ODBC;Driver={ODBC Driver 17 for SQL Server};Server=192.168.0.4;Database=testdbAllTables;Trusted_Connection=Yes;UID=sa;PWD=tv$akP4O30HM1TO2!9lI2z6c"
Set rs = db.OpenRecordset("SELECT Name FROM SysTrafficLinkTbls")
Do While Not rs.EOF
' Deletes Access table if exists
db.TableDefs.Delete rs!Name
' Link table
Set td = CurrentDb.CreateTableDef(rs!Name, dbAttachSavePWD, "dbo." & rs!Name, connString)
db.TableDefs.Append td
rs.MoveNext
Loop
End Sub

Consider this segment of your code:
' Deletes Access table if exists
db.TableDefs.Delete rs!Name
The comment says to delete the table if it exists. However your code will attempt to delete a table whether or not it exists. And when the table doesn't exist, attempting to delete it triggers that 3265 error: "Item not found in this collection."
There are two approaches you can use to avoid that error.
Check whether the table exists and only attempt the delete when it does exist.
Revise the code to ignore the 3265 error.
The sample code you included in your previous question uses the first approach. It looks through the TableDefs collection to see if the table is present, and only calls db.TableDefs.Delete when the table is found.
Here's an example of the second approach.
On Error GoTo LinkODBC_Err
Set db = CurrentDb()
connString = "ODBC;Driver={ODBC Driver 17 for SQL Server};Server=192.168.0.4;Database=testdbAllTables;Trusted_Connection=Yes;UID=sa;PWD=tv$akP4O30HM1TO2!9lI2z6c"
Set rs = db.OpenRecordset("SELECT [Name] FROM SysTrafficLinkTbls")
Do While Not rs.EOF
' Delete Access table
db.TableDefs.Delete rs!Name
' Link table
Set td = CurrentDb.CreateTableDef(rs!Name, dbAttachSavePWD, "dbo." & rs!Name, connString)
db.TableDefs.Append td
rs.MoveNext
Loop
LinkODBC_Exit:
Exit Sub
LinkODBC_Err:
Select Case Err.Number
Case 3265 'Item not found in this collection
Resume Next ' ignore the error and continue on
Case Else
' for any other errors, notify the user and exit
MsgBox Err.Number & ": " & Err.Description
Resume LinkODBC_Exit
End Select
End Sub

There are a few ways to do this. Here's one option.
DoCmd.TransferDatabase _
acImport, _
"ODBC Database", _
"ODBC;Driver={SQL Server};Server=Fos;Database=Hermes;Trusted_Connection=Yes", _
acTable, _
"sourceTable", _
"targetTable"

Related

How to use vba to automate the creation of queries in access

I'm trying to automate the creation of queries in my access database using VBA. I currently have a table with over 1000 entries with four columns (id, name, last name & age) and i want it to automatically create queries for each number found in the "age" column. For example, if in the list of 1000 there are only 10 people that are 40 years old, then i want it to create a query named "Age 40" and only shown the name and last name of those 10 people and do the same for all the other ages.
New to access vba so i dont know where to start.
Firstly, you should not be storing the age in a table - it should be calculated as needed (what happens tomorrow - chances are some of the people will have a birthday)
Anyway, consider using a recordset to get a list of the unique ages, and then using that to create each query. Something like:
Sub sAgeQuery1()
On Error GoTo E_Handle
Dim db As DAO.Database
Dim rsSteer As DAO.Recordset
Dim qdf As DAO.QueryDef
Set db = CurrentDb
Set rsSteer = db.OpenRecordset("SELECT DISTINCT Age FROM tblAge ORDER BY Age ASC;")
If Not (rsSteer.BOF And rsSteer.EOF) Then
Do
Set qdf = db.CreateQueryDef("qryAge" & rsSteer!Age, "SELECT * FROM tblAge WHERE Age=" & rsSteer!Age & " ORDER BY LastName, [Name];")
rsSteer.MoveNext
Loop Until rsSteer.EOF
db.QueryDefs.Refresh
End If
sExit:
On Error Resume Next
Set qdf = Nothing
rsSteer.Close
Set rsSteer = Nothing
Set db = Nothing
Exit Sub
E_Handle:
Select Case Err.Number
Case 3012 ' query already exists
Resume Next
Case Else
MsgBox Err.Description & vbCrLf & vbCrLf & "sAgeQuery1", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Select
End Sub
However, this is probably not the way to do it - you have not said why you think you need to create all of these queries. Possibly a better way would be to have just one query, and alter the SQL in the recordset's loop before doing something with the query:
Sub sAgeQuery2()
On Error GoTo E_Handle
Dim db As DAO.Database
Dim rsSteer As DAO.Recordset
Dim qdf As DAO.QueryDef
Set db = CurrentDb
Set rsSteer = db.OpenRecordset("SELECT DISTINCT Age FROM tblAge ORDER By Age ASC;")
If Not (rsSteer.BOF And rsSteer.EOF) Then
Set qdf = db.CreateQueryDef("qryAge")
Do
qdf.SQL = "SELECT * FROM tblAge WHERE Age=" & rsSteer!Age
' do something with this query (export as an excel/csv file perhaps)
rsSteer.MoveNext
Loop Until rsSteer.EOF
End If
sExit:
On Error Resume Next
rsSteer.Close
Set rsSteer = Nothing
DoCmd.DeleteObject acQuery, "qryAge"
Set qdf = Nothing
Set db = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sAgeQuery2", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub

ACCESS SQL Adding Multiple Columns If They Don't Exist

I'm trying to add several new columns to a table that already exists in Access 2007 or 2010 with a query. Right now my code looks like this (yes, I'm terribly new to this):
ALTER TABLE AC_PROPERTY
ADD JAB_1 double,
JAB_2 double,
JAB_3 double;
This correctly adds the three columns when none of them already exist, but if any of them exist I get an error message and the query fails to run. I need it to add each columns only if it does not exist. Can anyone please help with what my code should look like to check if each column exists before trying to add it?
NOTE: I would just do 3 queries for each column, but I actually need to add 20+ columns. This is just a simple example of my actual use.
Thanks a billion!
Here is some old code.... it would be better to just check all fields in the same subroutine rather than opening/closing the DB, TDF, etc.
Option Compare Database
Option Explicit
Function Check_If_Exists()
Dim strStatus As String
' Add calls for the fields you want to append
strStatus = Add_Field("MyFLd2", "Double")
If strStatus = "Exists" Then
Debug.Print "field present"
ElseIf strStatus = "Added" Then
Debug.Print "field added"
End If
End Function
Function Add_Field(strFN, strType) As String
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim fd As DAO.Field
Dim strSQL As String
On Error GoTo Error_Trap
Set db = CurrentDb
Set td = db.TableDefs("Table1")
' ' List all field names
' For Each fd In td.Fields
' Debug.Print fd.Name
' Next fd
If IsNull(td.Fields(strFN)) Then
Add_Field = "Exists"
End If
Set fd = Nothing
Set td = Nothing
Set db = Nothing
Exit Function
Error_Trap:
Debug.Print Err.Number & vbTab & Err.Description
If Err.Number = 3265 Then
Add_Field = "Added"
strSQL = "alter table Table1 ADD " & strFN & " " & strType & ";"
db.Execute strSQL
db.TableDefs.Refresh
End If
Exit Function
Resume
End Function

detecting whether some records are excluded from an INSERT INTO operation

I have a composite primary key on 2 columns in the table I am INSERTing into. I come from working with SQL Server, and I know that if I attempted to insert a duplicate key value into a PK table, it would throw an error.
My problem is, my code is not throwing this kind of error. Can you look at it and see if it's a problem with the code? Or does Access not throw errors for this kind of violation?
[Edit]
I guess I'm looking for a way to just acknowledge that duplicate records are attempted to be inserted. I want the current functionality to remain (dups are tossed; valid records are inserted). I don't want the entire INSERT to get rolled back.
My code is below.
Function InsertData(Ignore As String)
' define file path of CSV to be imported
Dim CurrentDate As String
Dim CurrentYear As String
CurrentDate = Format(Date, "yyyymmdd")
CurrentYear = Format(Date, "yyyy")
Dim Exfile As String
Exfile = iPath + "\" + CurrentYear + "\" + "FileName" + CurrentDate + ".txt"
'this calls a saved import routine
DoCmd.RunSavedImportExport "tbl_TEMP"
'merge data with that already existing in tbl_Perm.
'the clustered PK on product_ID and As_of_Date prevents dup insertion
Dim dbs As Database
Dim errLoop As Error
Set dbs = OpenDatabase(iPath + "\ExDatabase.mdb")
dbs.Execute " INSERT INTO tbl_Perm (Col1,Col2,Date_Created) " _
& "SELECT ColA + ColB, ColC, Format$(Now(),'Short Date')" _
& "FROM tbl_TEMP;"
' Trap for errors, checking the Errors collection if necessary.
On Error GoTo Err_Execute
'delete temp table
dbs.Execute "DROP TABLE tbl_TEMP;"
dbs.Close
Err_Execute:
' Notify user of any errors that result from
' executing the query.
If DBEngine.Errors.Count > 0 Then
For Each errLoop In DBEngine.Errors
MsgBox "Error number: " & errLoop.Number & vbCr & _
errLoop.Description
Next errLoop
End If
Resume Next
End Function
From the Microsoft DAO Doc (here):
In a Microsoft Access workspace, if you provide a syntactically
correct SQL statement and have the appropriate permissions, the
Execute method won't fail — even if not a single row can be modified
or deleted. Therefore, always use the dbFailOnError option when using
the Execute method to run an update or delete query. This option
generates a run-time error and rolls back all successful changes if
any of the records affected are locked and can't be updated or
deleted.
So add the dbFailOnError option to your call.
If you want to allow the INSERT to proceed and determine whether any duplicates were rejected then you could do something like this
Dim cdb As DAO.Database, qdf As DAO.QueryDef, rst As DAO.Recordset
Dim sqlSelect As String, sourceRecords As Long
Set cdb = CurrentDb
sqlSelect = _
"SELECT ColA + ColB, ColC, Format$(Now(),'Short Date') " & _
"FROM tbl_TEMP"
Set rst = cdb.OpenRecordset("SELECT COUNT(*) AS n FROM (" & sqlSelect & ")", dbOpenSnapshot)
sourceRecords = rst!n
rst.Close
Set rst = Nothing
Set qdf = cdb.CreateQueryDef("", _
"INSERT INTO tbl_Perm (Col1,Col2,Date_Created) " & sqlSelect)
qdf.Execute
If qdf.RecordsAffected < sourceRecords Then
Debug.Print sourceRecords - qdf.RecordsAffected & " record(s) not inserted"
End If
Set qdf = Nothing
Set cdb = Nothing
The line
On Error GoTo Err_Execute
is after you execute your SQL statement. The Err_Execute block will - in this case - be called every time because there is not statement like Exit Function before the label. I am not sure what happens to the errors if you close the connection before evaluating the error collection.

How to delete data in all ms-access tables at once?

Is there a way in MS-Access to delete the data in all the tables at once. We run a database in access, save the data every month and then delete all the data in access. But it requires deleting data from a lot of tables. Isn't there a simpler/easier way to do so?
Why don't you keep an empty copy of the database on hand. At the end of the month, save the existing database, then copy the empty database in its place.
Craig's answer is simple and sensible. If you really want a programmatic solution, the following VBA script will clear all the data from every table excluding the hidden tables. It requires DAO to be enabled - in Visual Basic Editor, go to Tools -> References, and tick Microsoft DAO 3.6 Object Library, then OK:
Public Sub TruncateTables()
'Majority of code taken from a data dictionary script I can no longer source nor find the author
On Error GoTo Error_TruncateTables
Dim DB As DAO.Database
Dim TDF As DAO.TableDef
Dim strSQL_DELETE As String
Set DB = CurrentDb()
For Each TDF In DB.TableDefs
If Left(TDF.Name, 4) <> "MSys" Then
strSQL_DELETE = "DELETE FROM " & TDF.Name & ";"
DB.Execute strSQL_DELETE
End If
Next
MsgBox "Tables have been truncated", vbInformation, "TABLES TRUNCATED"
DB.Close
Exit_Error_TruncateTables:
Set TDF = Nothing
Set DB = Nothing
Exit Sub
Error_TruncateTables:
Select Case Err.Number
Case 3376
Resume Next 'Ignore error if table not found
Case 3270 'Property Not Found
Resume Next
Case Else
MsgBox Err.Number & ": " & Err.Description
Resume Exit_Error_TruncateTables
End Select
End Sub
Great answer from Alistair, although it needs to be updated. The old if statement would cause errors, and the old dynamic string wouldn't work on tables with names that have a space. It would treat a name like "person information" as "person". I've updated the code, as well as made it a little easier to add exceptions to the if statement, if you want some tables to retain their data.
Public Sub TruncateTables()
'Majority of code taken from a data dictionary script I can no longer source nor find the author
On Error GoTo Error_TruncateTables
Dim DB As DAO.Database
Dim TDF As DAO.TableDef
Dim strSQL_DELETE As String
Set DB = CurrentDb()
For Each TDF In DB.TableDefs
If Not (TDF.Name Like "MSys*" Or TDF.Name Like "~*" Or Len(TDF.Connect) > 0) Then
'This will prevent system, temporary and linked tables from being cleared
strSQL_DELETE = "DELETE FROM " & "[" & TDF.Name & "]"
DB.Execute strSQL_DELETE
End If
Next
MsgBox "Tables have been truncated", vbInformation, "TABLES TRUNCATED"
DB.Close
Exit_Error_TruncateTables:
Set TDF = Nothing
Set DB = Nothing
Exit Sub
Error_TruncateTables:
Select Case Err.Number
Case 3376
Resume Next 'Ignore error if table not found
Case 3270 'Property Not Found
Resume Next
Case Else
MsgBox Err.Number & ": " & Err.Description
Resume Exit_Error_TruncateTables
End Select
End Sub
Since this is a repetitive action, it would be better if you made a simple SQL script to do this.
DELETE FROM <table1>;
DELETE FROM <table2>;
...
DELETE FROM <tablen>;
Highlight all of the ROWS and then press the Delete key on your keyboard. If access is doing that thing were it doesn't let you go to the bottom,then go into a cell and click ctrl+down arrow. To highlight all rows, highlight the top row and then scroll to the bottom row and hold down shift while you select the bottom row. All rows should be highlighted.
This will delete all the data from all tables except from System Tables
Dim T As TableDef
DoCmd.SetWarnings False
For Each T In CurrentDb.TableDefs
If T.Name Like "d2s_*" Then
DoCmd.RunSQL "DELETE * FROM " & T.Name
End If
Next T
DoCmd.SetWarnings True
Another approach: (Based on Suggestion of Christopher Duke)
Dim T As TableDef
DoCmd.SetWarnings False
For Each T In CurrentDb.TableDefs
If Not Left(T.Name, 4) = "MSys" Then
DoCmd.RunSQL "DELETE * FROM [" & T.Name & "]"
End If
Next T
DoCmd.SetWarnings True

I get error 3125 when I try to delete a linked table

I'm trying to delete all the linked tables in my front end, but it fails on the first table with the error: 3125 "'attendeesSearch' is not a valid name. Make sure that it does not include invalid characters or punctuation and that it is not too long.".
This table contains a multi-valued field. I include this because it may be an issue.
I've tried using "Drop table..." SQL and DoCmd.DeleteObject method.
My routine:
Sub relinkRequestHelp()
Const csConnnectPrefix As String = ";DATABASE="
Dim bLenConnectPrefix As Byte
Dim db As dao.Database
Dim tbl As dao.TableDef
Dim s As String
On Error GoTo eh
bLenConnectPrefix = Len(csConnnectPrefix)
Set db = CurrentDb()
For Each tbl In db.TableDefs
If Left(tbl.Connect, bLenConnectPrefix) = csConnnectPrefix Then
' s = "DROP TABLE " & tbl.Name & ";"
' Debug.Print s
' db.Execute s, dbFailOnError
' Debug.Print , db.RecordsAffected
DoCmd.DeleteObject acTable, tbl.Name
End If
Next
Exit Sub
eh: Debug.Print Err.Number, Err.Description
End Sub
Any suggestions?
Delete the current object from the collection. That works for me:
For Each tbl In db.TableDefs
If Left(tbl.Connect, bLenConnectPrefix) = csConnnectPrefix Then
db.TableDefs.Delete tbl.Name
End If
Next
In this post, Daniel Pineault suggested I remove the troubled table from all relationships.
Once I did that, I was able to delete the linked table.