Transactions using DAO and Sql Server linked tables - sql-server

I'm migrating a clasic Access application to Sql Server, i.e., DAO+Linked tables.
I've found a fustrating behavior: when i make changes using recordsets over linked tables, Access use more than one connection. More than one connection means more than one transaction at time on server side. These transactions are independent. Not nested.
Standard MS-Access behavior using linked tables to a .mdb files is different. There is only one transaction at time. Every db change is visible by any code that runs in the same DAO.Workspace before executing commit.
Rules has been changed and existing DAO code using client side transactions will fail.
If i add or update a record using a recordset open as dbOpenDynaset, any code trying to read them after will fail: Doesn't find new records and see existing records in the original state. Why? Because operations are maded in multiple and independent transactions
Executing the sample provided code, sql profiler will show you that different operations are made with different transactions ID's.
I've tested this using ADO and everything works well. But there are thousands code lines.
Is there any solution other than rewrite code using ADO?
Can i modify standard Access behaviour? ( use read uncommitted isolation level, instruct to not open new connections, ...)
Below code reproduces the problem. It's very simple:
1.- Open a recordset on existing record
2.- Add new record
3.- Try to read recently added record
If i use dbOpenDynaset in (1), i'll not see new record in (3).
I'm using Acc-2010, .accdb format files and Sql Server 2008 R2
Thanks.
Private Sub test0()
Dim bResult As Boolean
Dim bUseTrans As Boolean 'New record added in transaction
Dim rsExist As DAO.Recordset2 'Dummy recordset
Dim tRecordsetExist As DAO.RecordsetTypeEnum 'Dummy recordset type:
' with dbOpenDynaset fail.
' Any other works fine
Dim rs2Add As DAO.Recordset
Dim rs2Read As DAO.Recordset 'Used to read recently added record
Dim tRecordset2Read As DAO.RecordsetTypeEnum 'Recordset type used to read new record. Doesn't affect
Dim bTranInitiated As Boolean 'Track if we are in transaction
Dim lngExistingNumber As Long
Dim lngNewNumber As Long
Dim lngNewID As Long
Dim strSQL As String
On Error GoTo HandleErr
'Invoices table definition in SS. Table is linked as [dbo_Invoices]:
' CREATE TABLE [dbo].[Invoices](
' [IdInvoice] [int] IDENTITY(1,1) NOT NULL,
' [InvoiceNumber] [int] NOT NULL,
' [InvoiceDescription] [varchar](50) NOT NULL,
' CONSTRAINT [PK_Invoices] PRIMARY KEY CLUSTERED
' (
' [IdInvoice] Asc
' )WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]
' ) ON [PRIMARY]
Set wks = DBEngine.Workspaces(0)
Set dbs = wks.Databases(0)
bUseTrans = True 'Without transaction everything works well
tRecordsetExist = dbOpenDynaset 'Dummy recordset type:
' dbOpenDynaset makes fail.
' Any other works fine
tRecordset2Read = dbOpenForwardOnly 'Does not affect
lngExistingNumber = 12001
lngNewNumber = -lngExistingNumber
'Clean previous runs of the test and make sure that referenced invoice exists.
dbs.Execute "Delete from dbo_Invoices Where InvoiceNumber = " & lngNewNumber, dbFailOnError Or dbSeeChanges
On Error Resume Next
strSQL = "Insert Into dbo_Invoices (InvoiceNumber, InvoiceDescription) " & _
" Values (" & lngExistingNumber & ", 'Original invoice' )"
dbs.Execute strSQL, dbFailOnError Or dbSeeChanges
On Error GoTo HandleErr
If bUseTrans Then
wks.BeginTrans
bTranInitiated = True
End If
strSQL = "Select IdInvoice, InvoiceNumber from dbo_Invoices " & _
" Where InvoiceNumber = " & lngExistingNumber
If tRecordsetExist = dbOpenDynaset Then
Set rsExist = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
Else
Set rsExist = dbs.OpenRecordset(strSQL, tRecordsetExist)
End If
If rsExist.BOF And rsExist.EOF Then
Err.Raise vbObjectError, , "Original invoice " & lngExistingNumber & " not found"
End If
Set rs2Add = dbs.OpenRecordset("Select * from dbo_Invoices", dbOpenDynaset, dbAppendOnly Or dbSeeChanges)
rs2Add.AddNew
rs2Add!InvoiceNumber = lngNewNumber
rs2Add!InvoiceDescription = "Invoice anulation, ref " & lngExistingNumber
rs2Add.Update
'After executing .Update rs2Add goes to .EOF. This action reposition the recordset on the new record
rs2Add.Move 0, rs2Add.LastModified
lngNewID = rs2Add!IdInvoice
Debug.Print "New record added: IdInvoice = " & rs2Add!IdInvoice & ", InvoiceNumber = " & rs2Add!InvoiceNumber
'Try to read the new record
strSQL = "Select * from dbo_Invoices Where IdInvoice = " & lngNewID
If tRecordset2Read = dbOpenDynaset Then
Set rs2Read = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
Else
Set rs2Read = dbs.OpenRecordset(strSQL, tRecordset2Read)
End If
If (rs2Read.BOF And rs2Read.EOF) Then
Err.Raise vbObjectError, , "rs2Read: Not found using IdInvoice = " & lngNewID
End If
Debug.Print "New record found with IdInvoice = " & rs2Read!IdInvoice
rs2Read.Close
bResult = True
ExitHere:
If Not wks Is Nothing Then
If bTranInitiated Then
If bResult Then
wks.CommitTrans
Else
wks.Rollback
End If
bTranInitiated = False
End If
End If
On Error Resume Next
If Not rs2Add Is Nothing Then
rs2Add.Close
Set rs2Add = Nothing
End If
If Not rs2Read Is Nothing Then
rs2Read.Close
Set rs2Read = Nothing
End If
Exit Sub
HandleErr:
Dim e As Object
If Err.Description Like "ODBC*" Then
For Each e In DBEngine.Errors
MsgBox e.Description, vbCritical
Next
Else
MsgBox Err.Description, vbCritical
End If
bResult = False
Resume ExitHere
Resume
End Sub

Unfortunately, Microsoft states the following about Workspace.IsolateODBCTrans Property:
http://msdn.microsoft.com/en-us/library/office/bb208483(v=office.12).aspx
Some ODBC servers, such as Microsoft SQL Server, don't allow simultaneous transactions on a single connection. If you need to have more than one transaction at a time pending against such a database, set the IsolateODBCTrans property to True on each Workspace as soon as you open it. This forces a separate ODBC connection for each Workspace.
Not sure if this will help you deciding what to do.

You may continue to use dao for those tables that remain in the mdb. However for the sqlserver tables (linkled tables) like this:
Global objConn As New ADODB.Connection
and in the routine:
Dim rst As ADODB.Recordset
DoCmd.SetWarnings False
If objConn.State <> adStateOpen Then
MsgBox ("Connection to SQL server has not been made. Please exit and resolve problem.")
Exit Sub
End If
Set rst = New ADODB.Recordset
Dim stdocname As String
rst.Open "tblbilling", objConn, adOpenDynamic, adLockPessimistic
etc etc etc.....

Related

Excel VBA Runtime 3704 Operation is not allowed when object is closed

I have been using this code for some time and it works. As a matter of fact it works with a basic query. It just does not work with my new Stored Procedure. I can run the stored procedure manually. in SSMS and get my results. I thought that the error was when I was not getting data back so I added the . . . If myRS1.EOF Then . . . still getting the 3704 runtime error.
Here is my Excel (2013) Code
Private Sub cmdOK_Click()
Dim myStartDate, myEndDate
Dim myInsuranceCode
Dim objAD, objUser
Dim myDisplayName, myLastRow
Dim myMessage, myStyle, myTitle, myResult
Dim mySQL As String
Dim myConn
Dim myCmd
Dim myRS1
Dim myRange, myNamedRange, myCheckRange As Range
Dim X, Y, z
Dim myPercent, myLowEnd, myHighEnd
Dim myValue1, myValue2, myValue3, myValue4, myValue5, myValue6, myValue7, myValue8
Dim myCheckValue
Dim myHeaderRow, myDataRow, myLastColumn
'SET THESE ACCORDING TO THE REPORT. THE FIRST TWO MIGHT NOT NEED ANY CHANGES
myHeaderRow = 2
myDataRow = 3
myLastColumn = 22
'SETUP DATABASE OBJECTS
Set myConn = New ADODB.Connection
Set myCmd = New ADODB.Command
Set myRS1 = New ADODB.Recordset
Application.StatusBar = True
Application.StatusBar = "Connecting to SQL Server"
'GET DATES FROM TEH FORM AND SET SQL STATEMENT
myStartDate = frmMain.txtStartDate
myEndDate = frmMain.txtEndDate
'RUN INSURANCE STORE PROCEDURE
'SEPERATE THE INSURANCE CODE WITH A |
myInsuranceCode = "S19|S22"
mySQL = "dbo.BMH_rpt_PATIENTS_INSURANCE_LISTING '" & myStartDate & "', '" & myEndDate & "', '" & myInsuranceCode & "'"
'mySQL = "SELECT * FROM dbo.BETHESDA_ADMIT_SOURCE"
'HIDE THE FORM
frmMain.Hide
'GET THE USER THAT IS SIGNED IN
Set objAD = CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & objAD.UserName)
myDisplayName = objUser.DisplayName
'OPEN CONNECTIONS TO THE DATABASE
myConn.ConnectionString = "Provider=SQLOLEDB;Data Source=mySQLServer;Initial Catalog=myDatabaseName;User ID=user;Password=xxxxxxxx;Connection Timeout=300;"
myConn.Open
'SET AND EXECUTE SQL COMMAND
Set myCmd.ActiveConnection = myConn
myCmd.CommandText = mySQL
myCmd.CommandType = adCmdText
Application.StatusBar = "Running Stored Procedure " & mySQL
myCmd.CommandTimeout = 3000
'OPEN RECORDSET
Set myRS1.Source = myCmd
myRS1.Open
'CHECK TO MAKE SURE WE ARE NOT AT THE BOTTOM OF THE SHEET COULD MEAN THERE WAS NOT DATA LAST TIME.
'THIS SAME CODE WILL REPEAT FOR THE DATA TAB
'*********** DATA *************
'CHECK TO MAKE SURE THERE IS DATA
If myRS1.EOF Then <---- THIS IS THE LINE I AM GETTING THE ERROR
Cells(myDataRow, 1).Value = "No Data Qualifies"
myMessage = "No data qualifing for your request " & mySQL
myTitle = "No Data"
myStyle = vbCritical + vbOKOnly
myResult = MsgBox(myMessage, myStyle, myTitle)
Exit Sub
End If
'SELECT THE SHEET TO CLEAR OUT THE OLD data on DATA
'IF THIS IS NOT SET ON THE SEEHET IT WILL FAIL
Set myTable = Sheets("DATA").ListObjects("DATA")
If Cells(myDataRow, 1).Value <> "" Then
myTable.DataBodyRange.Rows.Delete
End If
'COPY THE DATA TO EXCEL
Application.StatusBar = "Copying the new data."
Sheets("DATA").Cells(myDataRow, 1).CopyFromRecordset myRS1
Cells(1048576, 1).Select
Selection.End(xlUp).Select
myLastRow = ActiveCell.Row
'Application.StatusBar = "Naming the new DATA range"
'ActiveWorkbook.Names.Add Name:=myNamedRange, RefersTo:=Range(Cells(myHeaderRow, 1), Cells(myLastRow, myLastColumn))
myTable.Resize Range(Cells(myHeaderRow, 1), Cells(myLastRow, myLastColumn))
End Sub
*** This is all the VBA Code now. It is failing on the myRS1.EOF line so none of the other code even runs.
As you can see I have two mySQL statements. The first one is not working, but the second one works no issue.
If I run the SP from SSMS or even take the mySQL that is generated it runs fine in SSMS.
Here is the SP
--EXAMPLE
-- dbo.BMH_rpt_PATIENTS_INSURANCE_LISTING '11/01/2020', '11/30/2020', 'S19|S22'
ALTER PROCEDURE [dbo].[BMH_rpt_PATIENTS_INSURANCE_LISTING]
#StartDate AS DATETIME,
#EndDate AS DATETIME,
#Insurance AS VARCHAR(MAX)
AS
/** GET THE INSURANCE CODES **/
SELECT VALUE
INTO #INSURANCE
FROM STRING_SPLIT(#Insurance, '|')
/** GET THE PATIENTS FOR THE LIST **/
SELECT vv.pt_id AS 'Patient Account',
vv.alt_med_rec_no AS 'MRN'
FROM smsdss.vst_v AS vv
WHERE vv.pyr_cd IN (SELECT * FROM #INSURANCE)
AND vv.start_full_date BETWEEN #StartDate AND #EndDate
AND vv.tot_bal_amt <> 0

Error on opening qd.openrecordset

What is wrong in this sample ? It breaks where indicated, even while the tbl name provided is the one of a perfectly working linked table.
Sub showLinked(tbl As String)
'tbl is the name of an existing local linked table (SQL Server)'
Dim db As DAO.Database, rs As DAO.Recordset
Dim qd As QueryDef
Set db = CurrentDb
With db.TableDefs(tbl)
Debug.Print .Name, .SourceTableName, .Connect
Set qd = db.CreateQueryDef("")
qd.Connect = .Connect
qd.SQL = "select 1 xxx from " & .SourceTableName
qd.ReturnsRecords = True
Set rs = qd.OpenRecordset() 'breaks here: error 3146 - "ODBC--call failed"
Debug.Print "test connection:", rs.Fields(0)
End With
End Sub
Found the culprit: I was testing my function on an Access table called Data_Archive_Transaction and its SourceTableName is Data_Archive.Transaction (not my name, I promise).
Since Transaction is a reserved word, in a SELECT it must be surrounded with brackets: Data_Archive.[Transaction].
I tried with another table with a more normal name and it worked fine.

Update Access 2003 MDB to point to a different SQL Server database

Access 2003 / SQL Server - how can I update Access 2003 MDB (Connect property) to point to a different SQL Server database? The new SQL Server database is on the same instance as the old one.
I have several MS Access 2003/SQL Server applications that I manage. All of them dynamically attach to the correct database at startup. Some of them even connect to multiple databases on different servers during the start up sequence. All of them use the same basic vba routine to actually dynamically attach a table to the correct server. This is not my code, I found it by googling around the internet, but I have lost the reference to it now, so apologies in advance to the authors.
Before showing the code, to put it in context, I normally have a form "frmInitApp" with a data source that is a local config table, with a field named "ID". I start the access application from the AutoExec macro which opens this form with a filter of "ID=1". I have other forms to manipulate this config table and change the IDs around, so to switch between production and test I just change which entry has ID=1.
I also have another local table, tableList, with a list of Access tables that I want to connect dynamically to a SQL Server. Most applications have another field in this table for the SQL Server table name (so they don't have to be the same) - some applications have an additional field to specify which database. But the more complex the more other spaghetti you need - I often end up with another table of connection strings to all the separate databases I might connect to etc etc. To keep it simple just have the connection string in a field in the config table that is the datasource to frmInitApp.
We get started with the current event on frmInitApp.
Private Sub Form_Current()
If Me.Filter = "" Then 'If nobody has told us what record to use then use id=1
Me.Filter = "[ID]=1"
configID = 1
Else
configID = CInt(Mid(Me.Filter, 6)) 'We are assuming the load criteria are "[ID]=..."
End If
Me.messages = "Connecting to databases ..."
DoCmd.Hourglass True
Me.stage = "InitialStartup" 'Set the stage which is to be executed during timer phase
Me.TimerInterval = 100 'We set the time to go off to so we can let autoexec finish and let us control focus
End Sub
and then in the timer we can link to the tables via an attach table function with I'll put further down the answer. Note also that we relink pass through queries as well so they point to the new database also. Also note that we start Open a new form a login one fore users as soon as we have attached to the first table. I don't show the conclusion where will probably have to validate username and password against the attached table when its all done, but its trivial to figure out anyway.
Private Sub Form_Timer()
Dim conn As ADODB.Connection
Dim dbRs As ADODB.Recordset
Dim dbOK As Boolean
Dim SQL As String
Dim startedLogon As Boolean
Me.TimerInterval = 0
Select Case Me.stage
Case "InitialStartup"
Set conn = CurrentProject.Connection
startedLogon = False
If CurrentProject.AllForms("frmLogon").IsLoaded Then
'If its already loaded this NOT the first time through, but still need to logon ...
If Form_frmLogon.configID = configID Then
startedLogon = True 'unless its the same config
End If
End If
dbOK = True
Set dbRs = New ADODB.Recordset
dbRs.Open "SELECT localname,servername FROM tableList", conn
While dbOK And Not dbRs.EOF
'PLEASE NOTE - WHILST THEORETICALLY "localname" and "servername" could be different the migration process
'requires that they be the same. Do not consider changing this until after migration is completed
dbOK = AttachTable(dbRs("localname"), "dbo." & dbRs("servername"))
dbRs.MoveNext
If Not startedLogon And dbOK Then
DoCmd.Close acForm, "frmLogon" '#554 Just in case its alread open - we need to pick up new params
DoCmd.OpenForm "frmLogon", , , , , , Nz(Me.lastUserId, "") & ":" & configID
Form_frmLogon.SetFocus '#748 Give it focus
startedLogon = True
End If
Wend
dbRs.Close
If dbOK Then
Me.messages = "Relinking Common Queries ..."
DoEvents
Dim qd As DAO.QueryDef, cs As String
cs = getStrConnDAO 'get the DAO connection string
For Each qd In CurrentDb.QueryDefs
If Len(qd.Connect & vbNullString) > 0 Then
qd.Connect = cs
End If
Next
End If
Me.messages = "Awaiting User Log On"
DoCmd.Hourglass False
DoEvents
... the rest just managing logon
End Sub
The attached table function
'//Name : AttachTable
'//Purpose : Create a linked table to SQL Server without using a DSN
'//Parameters
'// stLocalTableName: Name of the table that you are creating in the current database
'// stRemoteTableName: Name of the table that you are linking to on the SQL Server database
Private Function AttachTable(stLocalTableName As String, stRemoteTableName As String)
Dim td As TableDef
Dim stConnect As String
Me.messages = "Connecting to Database Table " & Me.mainDatabase & "." & stRemoteTableName
DoEvents
On Error Resume Next
CurrentDb.TableDefs.Delete stLocalTableName
If Err.Number <> 0 Then
If Err.Number <> 3265 Then GoTo AttachTable_Err 'v4.0.44 - allow delete errors
Err.Clear
End If
On Error GoTo AttachTable_Err
Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stRemoteTableName, getStrConnDAO(configID))
CurrentDb.TableDefs.Append td
DoEvents
AttachTable = True
Exit Function
AttachTable_Err:
AttachTable = False
errMsg = "AttachTable encountered an unexpected error: " & Err.description & " on table " & stRemoteTableName & " in database " & Me.mainDatabase
End Function
You will need to getConStrDAO function
Private ADOconnStr As String
Private DAOconnStr As String
Public Function getStrConn(Optional configID As Long = 0) As String
'create a connection string for use when running stored procedures
'this uses the saved value if possible, but global variables are reset if an error occurs
If ADOconnStr = "" Then
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim account As String
Dim revealedPassword As String
Dim s As String, i As Integer, x As String
Set conn = CurrentProject.Connection
If configID = 0 Then configID = Nz(Form_frmLogon.configID, 0)
Set rs = conn.Execute("SELECT * FROM localConfig WHERE id =" & configID)
If Not rs.EOF Then
ADOconnStr = "Provider=Microsoft.Access.OLEDB.10.0;Data Provider=SQLOLEDB;SERVER=" 'this provider is needed to allow use of SP as form.recordset
ADOconnStr = ADOconnStr & rs("ServerName") & ";DATABASE=" & rs("DatabaseName") & ";UID="
ADOconnStr = ADOconnStr & rs("dbUser") & ";PWD=" & EncryptDecrypt(Nz(rs("dbPassword"), ""))
End If
rs.Close
Set rs = Nothing
Set conn = Nothing
End If
getStrConn = ADOconnStr
End Function
Public Sub resetConnection()
ADOconnStr = ""
DAOconnStr = ""
End Sub
Function getStrConnDAO(Optional configID As Long = 0) As String
If DAOconnStr = "" Then
Dim a As New ADODB.Connection
a.Open getStrConn(configID)
DAOconnStr = "ODBC;driver=SQL Server;" & a.Properties("Extended Properties") & ";"
Set a = Nothing
End If
getStrConnDAO = DAOconnStr
End Function
And finally a simple encryption of database password to make it not obvious to casual eyes - something again copied from the internet
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Performs XOr encryption/decryption on string data. Passing a
''' string through the procedure once encrypts it, passing it
''' through a second time decrypts it.
'''
''' Arguments: szData [in|out] A string containing the data to
''' encrypt or decrypt.
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 05/18/05 Rob Bovey Created
'''
Public Function EncryptDecrypt(szData As String) As String
Const lKEY_VALUE As Long = 215
Dim bytData() As Byte
Dim lCount As Long
bytData = szData
For lCount = LBound(bytData) To UBound(bytData)
bytData(lCount) = bytData(lCount) Xor lKEY_VALUE
Next lCount
EncryptDecrypt = bytData
End Function

while rs edit update not working as expected

I have put together a procedure to cycle through a table containing paths to text files and import them into the database.
Reason for procedure:
The reason for this is I am building a back end to many reporting databases that rely on nightly updated text files. Recently they changed the server name and file names for these files, so I'm trying to build something more reliable so I don't have to run through the link table wizard making sure all the data types are exactly the same as before.
Issue:
The issue I have is the With .edit .update isn't acting like I thought it should and updating the field 'Updated' in the table to today's date.
Here is the code. I'm still new to programming, so apologies.
Private Sub ImportAll()
' Loops through table containing paths to text files on network and imports
Dim ID As Integer
Dim netPath As String
Dim netDir As String
Dim netFile As String
Dim localTable As String
Dim activeTable As Boolean
Dim updatedTable As Date
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Tables")
Do Until rst.EOF
ID = rst.Fields("Table ID").Value
netDir = rst.Fields("Network Location").Value
netFile = rst.Fields("File Name").Value
localTable = rst.Fields("Local Table Name").Value
activeTable = rst.Fields("Active").Value
updatedTable = rst.Fields("Updated").Value
If activeTable = True And updatedTable <> Date Then
If ifTableExists(localTable) Then
On Error GoTo ImportData_Err
CurrentDb.Execute "DELETE * FROM " & localTable, dbFailOnError
netPath = netDir & netFile
DoCmd.TransferText acImportDelim, , localTable, netPath, True, ""
rst.Edit
updatedTable = Date
rst.Update
Else
netPath = netDir & netFile
DoCmd.TransferText acImportDelim, , localTable, netPath, True, ""
With rs
.Edit
.Fields("Updated") = Date
.Update
End With
End If
End If
rst.MoveNext
Loop
rst.Close
Set rst = Nothing
ImportData_Exit:
Exit Sub
ImportData_Err:
MsgBox Error$
Resume ImportData_Exit
End Sub
Thank you.
Where you have
With rs
You meant
With rst
Mistakes such as this can be caught by turning on Option Explicit. Option Explicit means that all variables must be declared.
See here: How do I force VBA/Access to require variables to be defined?

VBA: Robust Database creation

i find this code, when trying to create db, using adodb and adox.
Here you can check original, it is the same. Thanks for author
Private Sub Command1_Click()
Dim db_file As String
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim num_records As Integer
' Get the database name.
db_file = App.Path
If Right$(db_file, 1) <> "\" Then db_file = db_file & _
"\"
db_file = db_file & "People.mdb"
' Open a connection.
Set conn = New ADODB.Connection
conn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & db_file & ";" & _
"Persist Security Info=False"
conn.Open
' Drop the Employees table if it already exists.
On Error Resume Next
conn.Execute "DROP TABLE Employees"
On Error GoTo 0
' Create the Employees table.
conn.Execute _
"CREATE TABLE Employees(" & _
"EmployeeId INTEGER NOT NULL," & _
"LastName VARCHAR(40) NOT NULL," & _
"FirstName VARCHAR(40) NOT NULL)"
' Populate the table.
conn.Execute "INSERT INTO Employees VALUES (1, " & _
"'Anderson', 'Amy')"
conn.Execute "INSERT INTO Employees VALUES (1, 'Baker', " & _
" 'Betty')"
conn.Execute "INSERT INTO Employees VALUES (1, 'Cover', " & _
" 'Chauncey')"
' Add more records ...
' See how many records the table contains.
Set rs = conn.Execute("SELECT COUNT (*) FROM Employees")
num_records = rs.Fields(0)
conn.Close
MsgBox "Created " & num_records & " records", _
vbInformation, "Done"
End Sub
But how to make it more robust, so, i don't want to delete db.
How to check, if db exists and if db.tables contains my table?
additional question: am i right, that this code create db for ms-access 2007?
Thanks for help!
Your question includes these two:
How to check, if db exists and if db.tables contains my table?
am i right, that this code create db for ms-access 2007?
For the first part of #1, use the Dir() function.
If Len(Dir("C:\SomeFolder\YourDb.mdb")) > 0 Then
Debug.Print "db exists"
Else
Debug.Print "db not found"
End If
For the second part of #1, try this function. pTable is the name of the table you're checking for. pDbPath is the full path, including the file name, for the db file you want to examine. The path can be one which begins with a drive letter, or it can be a UNC path ( \\Server\Share\YourDb.mdb ).
Public Function TableExists(ByVal pTable As String, _
Optional ByVal pDbPath As String) As Boolean
'return True if pTable exists as either a native or linked table '
'pass any error to caller '
Dim blnReturn As Boolean
Dim db As DAO.Database
Dim tdf As DAO.TableDef
If Len(Trim(pDbPath)) > 0 Then
Set db = OpenDatabase(pDbPath)
Else
Set db = CurrentDb
End If
For Each tdf In db.TableDefs
If tdf.Name = pTable Then
blnReturn = True
Exit For
End If
Next tdf
Set tdf = Nothing
If Len(Trim(pDbPath)) > 0 Then
db.Close
End If
Set db = Nothing
TableExists = blnReturn
End Function
Regarding your second question, no that code you showed us does not create a db file for any Access version. If db_file is not the path to an existing db file, that code will throw an error at conn.Open. It does not create the missing db file.
However I doubt that code will compile as VBA, despite the fact you included VBA in your title and tagged your question as vba. Really you should have at least tried it first before including it in a question on Stack Overflow.
For creating a MDB file from VB6/VBA code you could use ADOX. Here's a sample function to create an MDB file.
Public Function CreateMDB(strDBPath As String) As Boolean
'To make code compile add a reference to Microsoft ADO Ext 2.x for DDL and Security
'(msADOX.dll)
Dim catDB As ADOX.Catalog
Dim tblNew As ADOX.Table
Dim keyPrim As New ADOX.Key
Set catDB = New ADOX.Catalog
If Dir(strDBPath) = "" Then
CreateMDB = False
End If
With catDB
.Create "Provider=Microsoft.Jet.OLEDB.4.0;Locale Identifier=" & _
1033 & ";Data Source=" & strDBPath
.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strDBPath
End With
Set tblNew = New ADOX.Table
With tblNew
.Name = "data"
With .Columns
.Append "Field_0", adVarWChar
.Append "Field_1", adVarWChar
.Append "Field_2", adVarWChar
.Append "Field_3", adVarWChar
End With
End With
catDB.Tables.Append tblNew
Set keyPrim = New ADOX.Key
With keyPrim
.Name = "Field_0"
.Type = adKeyPrimary
.RelatedTable = "data"
.Columns.Append "Field_0"
End With
catDB.Tables("data").Keys.Append keyPrim
Set catDB = Nothing
Set tblNew = Nothing
End Function

Resources