MS Access (Jet) transactions, workspaces - ms-access

I am having trouble with committing a transaction (using Access 2003 DAO). It's acting as if I never had called BeginTrans -- I get error 3034 on CommitTrans, "You tried to commit or rollback a transaction without first beginning a transaction"; and the changes are written to the database (presumably because they were never wrapped in a transaction). However, BeginTrans is run, if you step through it.
I am running it within the Access environment using the DBEngine(0) workspace.
The tables I'm adding records to are all opened via a Jet database connection (to the same database) and using DAO.Recordset.AddNew / Update.
The connection is opened before starting BeforeTrans.
I'm not doing anything weird in the middle of the transaction like closing/opening connections or multiple workspaces etc.
There are two nested transaction levels. Basically it's wrapping multiple inserts in an outer transaction, so if any fail they all fail. The inner transactions run without errors, it's the outer transaction that doesn't work.
Here are a few things I've looked into and ruled out:
The transaction is spread across several methods and BeginTrans and CommitTrans (and Rollback) are all in different places. But when I tried a simple test of running a transaction this way, it doesn't seem like this should matter.
I thought maybe the database connection gets closed when it goes out of local scope, even though I have another 'global' reference to it (I'm never sure what DAO does with dbase connections to be honest). But this seems not to be the case -- right before the commit, the connection and its recordsets are alive (I can check their properties, EOF = False, etc.)
My CommitTrans and Rollback are done within event callbacks. (Very basically: a parser program is throwing an 'onLoad' event at the end of parsing, which I am handling by either committing or rolling back the inserts I made during processing, depending on if any errors occurred.) However, again, trying a simple test, it doesn't seem like this should matter.
Any ideas why this isn't working for me?
Thanks.
EDIT 25 May
Here is the (simplified) code. The key points having to do with the transaction are:
The workspace is DBEngine(0), referenced within the public (global) variable APPSESSION.
The database connection is opened in LoadProcess.cache below, see the line Set db = APPSESSION.connectionTo(dbname_).
BeginTrans is called in LoadProcess.cache.
CommitTrans is called in the process__onLoad callback.
Rollback is called in the process__onInvalid callback.
Recordset updates are done in process__onLoadRow, logLoadInit, and logLoad
Eric
'-------------------
'Application globals
'-------------------
Public APPSESSION As DAOSession
'------------------
' Class LoadProcess
'------------------
Private WithEvents process_ As EventedParser
Private errs_ As New Collection
Private dbname_ As String
Private rawtable_ As String
Private logtable_ As String
Private isInTrans_ As Integer
Private raw_ As DAO.Recordset
Private log_ As DAO.Recordset
Private logid_ As Variant
Public Sub run
'--- pre-load
cache
resetOnRun ' resets load state variables per run, omitted here
logLoadInit
Set process_ = New EventedParser
'--- load
process_.Load
End Sub
' raised once per load() if any row invalid
Public Sub process__onInvalid(filename As String)
If isInTrans_ Then APPSESSION.Workspace.Rollback
End Sub
' raised once per load() if all rows valid, after load
Public Sub process__onLoad(filename As String)
If errs_.Count > 0 Then
logLoadFail filename, errs_
Else
logLoadOK filename
End If
If isInTrans_ Then APPSESSION.Workspace.CommitTrans
End Sub
' raised once per valid row
' append data to raw_ recordset
Public Sub process__onLoadRow(row As Dictionary)
On Error GoTo Err_
If raw_ Is Nothing Then GoTo Exit_
DAOext.appendFromHash raw_, row, , APPSESSION.Workspace
Exit_:
Exit Sub
Err_:
' runtime error handling done here, code omitted
Resume Exit_
End Sub
Private Sub cache()
Dim db As DAO.Database
' TODO raise error
If Len(dbname_) = 0 Then GoTo Exit_
Set db = APPSESSION.connectionTo(dbname_)
' TODO raise error
If db Is Nothing Then GoTo Exit_
Set raw_ = db.OpenRecordset(rawtable_), dbOpenDynaset)
Set log_ = db.OpenRecordset(logtable_), dbOpenDynaset)
APPSESSION.Workspace.BeginTrans
isInTrans_ = True
Exit_:
Set db = Nothing
End Sub
' Append initial record to log table
Private Sub logLoadInit()
Dim info As New Dictionary
On Error GoTo Err_
' TODO raise error?
If log_ Is Nothing Then GoTo Exit_
With info
.add "loadTime", Now
.add "loadBy", CurrentUser
End With
logid_ = DAOext.appendFromHash(log_, info, , APPSESSION.Workspace)
Exit_:
Exit Sub
Err_:
' runtime error handling done here, code omitted
Resume Exit_
End Sub
Private Sub logLoadOK(filename As String)
logLoad logid_, True, filename, New Collection
End Sub
Private Sub logLoadFail(filename As String, _
errs As Collection)
logLoad logid_, False, filename, errs
End Sub
' Update log table record added in logLoadInit
Private Sub logLoad(logID As Variant, _
isloaded As Boolean, _
filename As String, _
errs As Collection)
Dim info As New Dictionary
Dim er As Variant, strErrs As String
Dim ks As Variant, k As Variant
On Error GoTo Err_
' TODO raise error?
If log_ Is Nothing Then GoTo Exit_
If IsNull(logID) Then GoTo Exit_
For Each er In errs
strErrs = strErrs & IIf(Len(strErrs) = 0, "", vbCrLf) & CStr(er)
Next Er
With info
.add "loadTime", Now
.add "loadBy", CurrentUser
.add "loadRecs", nrecs
.add "loadSuccess", isloaded
.add "loadErrs", strErrs
.add "origPath", filename
End With
log_.Requery
log_.FindFirst "[logID]=" & Nz(logID)
If log_.NoMatch Then
'TODO raise error
Else
log_.Edit
ks = info.Keys
For Each k In ks
log_.Fields(k).Value = info(k)
Next k
log_.Update
End If
Exit_:
Exit Sub
Err_:
' runtime error handling done here, code omitted
Resume Exit_
End Sub
'-------------
' Class DAOExt
'-------------
' append to recordset from Dictionary, return autonumber id of new record
Public Function appendFromHash(rst As DAO.Recordset, _
rec As Dictionary, _
Optional map As Dictionary, _
Optional wrk As DAO.workspace) As Long
Dim flds() As Variant, vals() As Variant, ifld As Long, k As Variant
Dim f As DAO.Field, rst_id As DAO.Recordset
Dim isInTrans As Boolean, isPersistWrk As Boolean
On Error GoTo Err_
' set up map (code omitted here)
For Each k In rec.Keys
If Not map.Exists(CStr(k)) Then _
Err.Raise 3265, "appendFromHash", "No field mapping found for [" & CStr(k) & "]"
flds(ifld) = map(CStr(k))
vals(ifld) = rec(CStr(k))
ifld = ifld + 1
Next k
If wrk Is Nothing Then
isPersistWrk = False
Set wrk = DBEngine(0)
End If
wrk.BeginTrans
isInTrans = True
rst.AddNew
With rst
For ifld = 0 To UBound(flds)
.Fields(flds(ifld)).Value = vals(ifld)
Next ifld
End With
rst.Update
Set rst_id = wrk(0).OpenRecordset("SELECT ##Identity", DAO.dbOpenForwardOnly, DAO.dbReadOnly)
appendFromHash = rst_id.Fields(0).Value
wrk.CommitTrans
isInTrans = False
Exit_:
On Error GoTo 0
If isInTrans And Not wrk Is Nothing Then wrk.Rollback
If Not isPersistWrk Then Set wrk = Nothing
Exit Function
Err_:
' runtime error handling, code omitted here
Resume Exit_
End Function
'-----------------
' Class DAOSession (the part that deals with the workspace and dbase connections)
'-----------------
Private wrk_ As DAO.workspace
Private connects_ As New Dictionary
Private dbs_ As New Dictionary
Public Property Get workspace() As DAO.workspace
If wrk_ Is Nothing Then
If DBEngine.Workspaces.Count > 0 Then
Set wrk_ = DBEngine(0)
End If
End If
Set workspace = wrk_
End Property
Public Property Get connectionTo(dbname As String) As DAO.database
connectTo dbname
Set connectionTo = connects_(dbname)
End Property
Public Sub connectTo(dbname As String)
Dim Cancel As Integer
Dim cnn As DAO.database
Dim opts As Dictionary
Cancel = False
' if already connected, use cached reference
If connects_.Exists(dbname) Then GoTo Exit_
If wrk_ Is Nothing Then _
Set wrk_ = DBEngine(0)
' note opts is a dictionary of connection options, code omitted here
Set cnn = wrk_.OpenDatabase(dbs_(dbname), _
CInt(opts("DAO.OPTIONS")), _
CBool(opts("DAO.READONLY")), _
CStr(opts("DAO.CONNECT")))
' Cache reference to dbase connection
connects_.Add dbname, cnn
Exit_:
Set cnn = Nothing
Exit Sub
End Sub

Transactions are used by defining a workspace (it doesn't have to be a new one) and then beginning the transaction on that workspace, doing what you need to do with it, and then commiting the transaction if all is well. Skeletal code:
On Error GoTo errHandler
Dim wrk As DAO.Workspace
Set wrk = DBEngine(0) ' use default workspace
wrk.BeginTrans
[do whatever]
If [conditions are met] Then
wrk.CommitTrans
Else
wrk.Rollback
End If
errHandler:
Set wrk = Nothing
exitRoutine:
' do whatever you're going to do with errors
wrk.Rollback
Resume errHandler
Now, within the block where you [do whatever], you can pass off the workspace and databases and recordsets to subroutines, but the top-level control structure should remain in one place.
Your code does not do that -- instead, you depend on global variables. GLOBAL VARIABLES ARE EVIL. Don't use them. Instead, pass private variables as parameters to the subroutines you want to operate on them. I would also say, never pass the workspace -- only pass the objects you've created with the workspace.
Once you've absorbed that, maybe it will help you explain what your code is supposed to accomplish (which I haven't the foggiest idea of from reading through it), and then we can advise you as to what you're doing wrong.

OK, after much frustrating debugging, I think I uncovered a bug in Jet transactions. After all that, it has nothing to do with my "enormously convoluted" code or "evil global variables" :)
It appears that when the following is true, you get the error #3034:
You open a snapshot-type recordset
The recordset is opened before you start the transaction
The recordset is closed/dereferenced after you begin the transaction, but before the commit or rollback.
I haven't checked if this is already known, although I can't imagine it isn't.
Of course, it's kind of weird to do things in this order anyway and asking for trouble, I don't know why I did it. I moved opening/closing the snapshot recordset to within the transaction and everything works fine.
The following code exhibits the error:
Public Sub run()
Dim db As DAO.Database, qdf As DAO.QueryDef, rst As DAO.Recordset
Dim wrk As DAO.Workspace, isInTrans As Boolean
On Error GoTo Err_
Set wrk = DBEngine(0)
Set db = wrk(0)
Set rst = db.OpenRecordset("Table2", DAO.dbOpenSnapshot)
wrk.BeginTrans
isInTrans = True
Set qdf = db.CreateQueryDef("", "INSERT INTO [Table1] (Field1, Field2) VALUES (""Blow"", ""Laugh"");")
qdf.Execute dbFailOnError
Exit_:
Set rst = Nothing
Set qdf = Nothing
Set db = Nothing
If isInTrans Then wrk.CommitTrans
isInTrans = False
Exit Sub
Err_:
MsgBox Err.Description
If isInTrans Then wrk.Rollback
isInTrans = False
Resume Exit_
End Sub
And this fixes the error:
Public Sub run()
Dim db As DAO.Database, qdf As DAO.QueryDef, rst As DAO.Recordset
Dim wrk As DAO.Workspace, isInTrans As Boolean
On Error GoTo Err_
Set wrk = DBEngine(0)
Set db = wrk(0)
wrk.BeginTrans
isInTrans = True
' NOTE THIS LINE MOVED WITHIN THE TRANSACTION
Set rst = db.OpenRecordset("Table2", DAO.dbOpenSnapshot)
Set qdf = db.CreateQueryDef("", "INSERT INTO [Table1] (Field1, Field2) VALUES (""Blow"", ""Laugh"");")
qdf.Execute dbFailOnError
Exit_:
Set rst = Nothing
Set qdf = Nothing
Set db = Nothing
If isInTrans Then wrk.CommitTrans
isInTrans = False
Exit Sub
Err_:
MsgBox Err.Description
If isInTrans Then wrk.Rollback
isInTrans = False
Resume Exit_
End Sub

For what it is worth this seems to be a bit more widespread than just Access transactions. I have just encountered a similar situation using Access 2007 & DAO as a front end to MySQL. With MySQL Autocommit=0, The SQL transactions would nonetheless mysteriously commit themselves half way through a transaction.
After 2 weeks of head scratching I came across this post and looked at my code again. Sure enough, the MySQL inserts were being done by a Stored procedure that was called from within a VBA class module. This class module had a dao.recordset that was opened on module.initialize() and closed on terminate(). Furthermore, this recordset was used to collect the results of the stored procedure. So I had (in pseudo code...)
module.initialize - rs.open
class properties set by external functions
transaction.begins
Mysql procedure.calls using class properties as parameters -
commit(or rollback)
rs.populate
class properties.set
properties used by external functions
module terminate - rs.close
and the transactions were just not working. I tried everything imaginable for 2 weeks.
Once I declared and closed the rs within the transaction everything worked perfectly!

Related

MS Access DAO recordset update not working

I made a MS Access DB (old XP version) which used to work seamlessy.
I had to add a routine to "move" some data from a table to another, and wrote a function to do this.
The method I always used was to use dynamic recordsets (or dynasets), but this time it doesn't work.
The flow correctly opens dynasets, find and copy data from one recordset to the other, but when .update is done nothing appears in the original table.
I use DAO 3.60.
Here's the (summarized) code:
On Error Resume Next
Dim rstDoc As Recordset
Dim rstAdd As Recordset
Dim rstDocEmessi As Recordset
Dim rstAddDocEmessi As Recordset
Dim Incassato As Integer
Set rstDoc = CurrentDb.OpenRecordset("Documenti", dbOpenSnapshot)
Set rstDocEmessi = CurrentDb.OpenRecordset("TS_DocumentiEmessi", dbOpenDynaset)
Set rstAdd = CurrentDb.OpenRecordset("Addebiti", dbOpenDynaset)
Set rstAddDocEmessi = CurrentDb.OpenRecordset("TS_Addebiti_DocumentiEmessi", dbOpenDynaset)
numDoc = Forms!TS_SceltaStampa!IdDocumento
With rstDocEmessi
rstDocEmessi.AddNew
rstDocEmessi!IdDocOriginale = rstDoc!IdDocumento
rstDocEmessi!Data = rstDoc!Data
rstDocEmessi![#Fattura] = rstDoc![#Fattura]
...
rstDocEmessi!TS_Opposizione = rstDoc!TS_Opposizione
rstDocEmessi!TS_DataPagamento = rstDoc!TS_DataPagamento
rstDocEmessi!IsIncassato = (IIf(Incassato = vbYes, True, False))
rstDocEmessi!IsImportatoInSospesi = False
rstDocEmessi.Update
rstDocEmessi.Close
' Copia Addebiti
If Not (rstAdd.EOF And rstAdd.BOF) Then
rstAdd.MoveFirst
Do Until rstAdd.EOF = True
If rstAdd!Documento = numDoc Then
rstAddDocEmessi.AddNew
rstAddDocEmessi!IdAddebito = rstAdd!IdAddebito
rstAddDocEmessi!Documento = rstAdd!Documento
...
rstAdd!TS_TipoSpesa
rstAddDocEmessi!Calcola = rstAdd!Calcola
rstAddDocEmessi!Totale = rstAdd!Totale
rstAddDocEmessi.Update
End If
rstAdd.MoveNext
Loop
End If
rstAddDocEmessi.Close
rstAdd.Close
TS_Registra = True`
I have a few suggestions.
Firstly don't use On Error Resume Next unless you are expecting a particular error in a line of code that you are going to explicitly test for and handle in the very next line of code (by testing If Err.Number = ...). You should have an error handling code block and use On Error GoTo ERROR_CODE_BLOCK. If you are going to turn off the error handler for one particular command then you should turn it back on again straight after you've handled the expected error.
Because you've turned off error handling, it could be that your insert statements are failing due to some constraint violation but you're just not seeing this. For error handling I would recommend structuring your code like this:
On Error GoTo PROC_ERR
Dim rstDoc As Recordset
'...
'insert the body of your Procedure here
'...
PROC_EXIT:
'Add any tidying up code that always needs to run. For example, release all your Object variables
Set rstDoc = Nothing
Set rstAdd = Nothing
Set rstDocEmessi = Nothing
Set rstAddDocEmessi = Nothing
Exit Sub
PROC_ERR:
MsgBox "Error " & Err.Number & " - " & Err.Description
Resume PROC_EXIT
End Sub
General code tidying suggestions.
The With rstDocEmessi construct is used to save you a bit of typing. There should be an associated End With somewhere in your code, but I don't see this. I would change this bit of code as follows:
With rstDocEmessi
.AddNew
!IdDocOriginale = rstDoc!IdDocumento
!Data = rstDoc!Data
![#Fattura] = rstDoc![#Fattura]
...
!TS_Opposizione = rstDoc!TS_Opposizione
!TS_DataPagamento = rstDoc!TS_DataPagamento
!IsIncassato = (IIf(Incassato = vbYes, True, False))
!IsImportatoInSospesi = False
.Update
.Close
End With
Finally, the inserts into rstAddDocEmessi could be cleaned up a bit. Rather than opening the whole table of records for rstAdd and then checking each record in turn to see if you need to add a rstAddDocEmessi record, why not just get the relevant records in your rstAdd recordset?
Set rstAdd = CurrentDb.OpenRecordset("Select * From Addebiti " & _
"Where Documento = " & Forms!TS_SceltaStampa!IdDocumento, dbOpenDynaset)
'No need to test for (rstAdd.BOF And rstAdd.EOF), and no need for rstAdd.MoveFirst
'Just go straight into...
Do Until rstAdd.EOF = True
rstAddDocEmessi.AddNew
rstAddDocEmessi!IdAddebito = rstAdd!IdAddebito
rstAddDocEmessi!Documento = rstAdd!Documento
...
rstAddDocEmessi!Calcola = rstAdd!Calcola
rstAddDocEmessi!Totale = rstAdd!Totale
rstAddDocEmessi.Update
rstAdd.MoveNext
Loop

How to sort an Access DB Table, via VBA, displayed in order when opened by using the Navigation Pane

As an end of some inserts, via VBA script, I have been doing in an ACCESS table. I have as a requirement to order the table by a field. So a third person would open it via the ACCESS Navigation Pane and it would be shown in the specified order.
EDIT: I also need that table to be writable by this third person.
I can think about creating a new table, using an SQL sentence to order it. But it seems like a very ugly option.
Is there any way to archive it using a DAO object or other VBA approach?
A query which sorts the table is the cleanest solution.
If you don't want to create an extra object for that, you can set the table sorting with DAO properties like this:
Sub DoIt()
Call TableSetSort("myTable", "myField")
End Sub
' Set a table to be sorted by <sFieldname>
Public Sub TableSetSort(sTable As String, sFieldname As String)
Dim DB As Database
Dim tdf As TableDef
Dim prop As DAO.Property
Set DB = CurrentDb
Set tdf = DB.TableDefs(sTable)
' Set field to order by
Call TableAddProperty(tdf, "OrderBy", dbText, sFieldname)
' These two may be true by default, but better safe than sorry
Call TableAddProperty(tdf, "OrderByOn", dbBoolean, True)
Call TableAddProperty(tdf, "OrderByOnLoad", dbBoolean, True)
' if you want to debug
For Each prop In tdf.Properties
Debug.Print prop.Name, prop.Value
Next prop
End Sub
' Set or add a property in a TableDef
Public Sub TableAddProperty(tdf As DAO.TableDef, sName As String, iType As DAO.DataTypeEnum, vValue As Variant)
Dim prop As DAO.Property
' Try to set the property value, this will fail with Runtime Error 3270 if the property doesn't exist
On Error Resume Next
tdf.Properties(sName) = vValue
If Err.Number = 3270 Then
' Property doesn't exist yet - create and append it
On Error GoTo 0
Set prop = tdf.CreateProperty(sName, iType, vValue)
tdf.Properties.Append prop
End If
' Note: error handling here is quite minimal!
End Sub

How to properly use Seek in DAO database

I'm trying to search for currently selected item in my listbox control on my table.
In my listbox control after update event, I have this code
Private Sub lst_MainList_AfterUpdate()
Dim theDB As DAO.Database
Dim theProposalsTable As DAO.Recordset
Set theDB = CurrentDb
Set theProposalsTable = theDB.OpenRecordset("tbl_PROPOSAL", dbOpenDynaset)
theSeeker theProposalsTable, Me.lst_PPpg_MainList.Value
End Sub
Then I have a sub on my Module1 with this code. I got this from an example code # https://msdn.microsoft.com/en-us/library/office/ff836416.aspx
Sub theSeeker(ByRef rstTemp As Recordset, intSeek As Integer)
Dim theBookmark As Variant
Dim theMessage As String
With rstTemp
' Store current record location.
theBookmark = .Bookmark
.Seek "=", intSeek
' If Seek method fails, notify user and return to the
' last current record.
If .NoMatch Then
theMessage = "Not found! Returning to current record." & vbCr & vbCr & "NoMatch = " & .NoMatch
MsgBox theMessage
.Bookmark = theBookmark
End If
End With
End Sub
I am getting Runtime Error 3251 Operation is not supported for this type of object.
When I hit Debug, it highlights .Seek "=", intSeek
In this point from the linked page ...
Locates the record in an indexed table-type Recordset object
... "table-type Recordset" means you must use dbOpenTable instead of dbOpenDynaset with OpenRecordset()
That point is critical. If you can't open the table with dbOpenTable, you can't use Seek. And dbOpenTable can only be used with native Access tables contained in the current database. It can not be used with any kind of linked table.
So if dbOpenTable is compatible with tbl_PROPOSAL, this change will eliminate the first error ...
'Set theProposalsTable = theDB.OpenRecordset("tbl_PROPOSAL", dbOpenDynaset)
Set theProposalsTable = theDB.OpenRecordset("tbl_PROPOSAL", dbOpenTable)
If that does work, the next error will be #3019, "Operation invalid without a current index." That happens because you must set the controlling index before calling Seek ...
With rstTemp
' Store current record location.
theBookmark = .Bookmark
' Set the index.
.Index = "PrimaryKey" '<- use your index name here
.Seek "=", intSeek
If you need to list the names of your table's indexes, you can examine its TableDef.Indexes collection. Here is an Immediate window example with a table in my database ...
set db = CurrentDb
for each idx in db.TableDefs("tblFoo").Indexes : ? idx.name : next
id
PrimaryKey
You can't use the Seek method on a linked table because you can't open linked tables as table-type Recordset objects...
However, you can use the Seek method if you use the OpenDatabase method to open the backend database.
So instead of:
Set theDB = CurrentDb()
Do this:
Set theDB = OpenDatabase("full path to backend database")
Set theProposalsTable = theDB.OpenRecordset("tbl_PROPOSAL", dbOpenTable)
Allow me to combine these two old answers. Yes, you get an error when opening a linked table as dbOpenTable because that is only supported on tables local to the DB object you are working on. Like David pointed out, you can open the linked backend as a DB object and use that.
I'm using a reliable table in my back-end called "Settings". If you don't have a reliable table you can use to pull the back end you can pass in the table name as an argument.
I'm storing the backend object once I have a handle on it so we can call against it rapidly throughout our code without recreating the object.
Private thisBEDB As Database
'#Description("This allows us to call directly against linked tables.")
Public Function thisBackend() As Database
' For MS-ACCESS table
If (thisBEDB Is Nothing) Then
With DBEngine
Set thisBEDB = .OpenDatabase(Mid(CurrentDB.TableDefs("Settings").Connect, 11), False, False, "")
End With
End If
Set thisBackend = thisBEDB
End Function
Now we can use the backend handle to make the code in your example work as expected.
Private Sub lst_MainList_AfterUpdate()
Dim theDB As DAO.Database
Dim theProposalsTable As DAO.Recordset
Set theDB = CurrentDb
Set theProposalsTable = thisBackend.OpenRecordset("tbl_PROPOSAL", dbOpenTable)
theSeeker theProposalsTable, Me.lst_PPpg_MainList.Value
End Sub
Sub theSeeker(ByRef rstTemp As Recordset, intSeek As Integer)
Dim theBookmark As Variant
Dim theMessage As String
With rstTemp
.Index = "PrimaryKey"
' Store current record location.
theBookmark = .Bookmark
.Seek "=", intSeek
' If Seek method fails, notify user and return to the
' last current record.
If .NoMatch Then
theMessage = "Not found! Returning to current record." & vbCr & vbCr & "NoMatch = " & .NoMatch
MsgBox theMessage
.Bookmark = theBookmark
End If
End With
End Sub

passing Access.Application object to a function: Dim, Set, Object how to make it work?

I came upon this (modified) function in a Stack Overflow page and have been trying to get it to work without giving up on the passed object (if I handle the Access.Application strictly within the first routine it will work).
Yes I know of a number of ways to get the same answer (mostly from other posts on the stack), but there is a general concept here of passing objects to functions that I would like to master--please forget for a moment that the function checks the existence of a table.
Function FCN_CheckTblsExist(theDatabase As Access.Application, _
tableName As String) As Boolean
'access.Application.CurrentData.AllTables.Count
'etc is the 'workaround enabling disposal of
'the "theDatabase" object variable
' Presume that table does not exist.
FCN_CheckTblsExist = False
' Define iterator to query the object model.
Dim iTable As Integer
' Loop through object catalogue and compare with search term.
For iTable = 0 To theDatabase.CurrentData.AllTables.Count - 1
If theDatabase.CurrentData.AllTables(iTable).Name = tableName Then
FCN_CheckTblsExist = True
Exit Function
End If
Next iTable
End Function
Function callFCN_CheckTblsExist(tableName As String)
'this is an example of a curried function?--step down in dimensionality
Dim bo0 As String
Dim A As Object
Set A = CreateObject("Access.Application")
bo0 = FCN_CheckTblsExist(A, tableName)
MsgBox tableName & " Exists is " & bo0
End Function
I don't know if the (theDatabase As Access.Application, . ) part is correct, that may be the root of the problem, rather than the Dim, Set, Object (New?) gymnastics that may be required in the auxiliary procedure. Maybe there is a reference library problem (I'm running Access 2013).
Update: I am not sure the following is robust enough but this is what I meant earlier in the post, which is just being put here for completeness. BTW, this is not a split application so maybe that is why the following works. I appreciate HansUp's post, Not enough can be said on this subject. Anyway
Public Function FCN_CheckTblsExist(tableName As String) As Boolean 'Call this function once for every table
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim appAccess As New Access.Application
Dim theDatabase As Access.Application
' Presume that table does not exist.
FCN_CheckTblsExist = False
' Define iterator to query the object model.
Dim iTable As Integer
For iTable = 0 To Access.Application.CurrentData.AllTables.Count - 1
If Access.Application.CurrentData.AllTables(iTable).Name = tableName Then
FCN_CheckTblsExist = True
Exit Function
End If
Next iTable
End Function
Just wanted to add that this last function I posted technically would be considered to be partial or no currying depending on how much the scope of the function was limited by invoking "Access.Application.CurrentData.AllTables." as a substitute for "theDatabase", only substituting the specific string created by Access.Application.CurrentDb.Name into the original function ...(theDatabse,... would it be a true full currying.
Anyway passing objects to functions and the libraries and their methods are the primary focus of this discussion. When I get the DAO issue worked i should have a better feel for what may be going on and then I'll post and mark the best solution accordingly.
The problem is not really about passing an Access.Application object to your other function. Instead you create the Access.Application and later check for the existence of a table without having opened a database within that Access session. In that situation, theDatabase.CurrentData.AllTables.Count should trigger error
2467, "The expression you entered refers to an object that is closed or doesn't exist."
I revised both procedures and tested them in Access 2010. Both compile and run without errors and produce the result I think you want.
Function FCN_CheckTblsExist(theDatabase As Access.Application, _
tableName As String) As Boolean
Dim tdf As DAO.TableDef
Dim blnReturn As Boolean
blnReturn = False
For Each tdf In theDatabase.CurrentDb.TableDefs
If tdf.Name = tableName Then
blnReturn = True
Exit For
End If
Next ' tdf
FCN_CheckTblsExist = blnReturn
End Function
Function callFCN_CheckTblsExist(DbPath As String, tableName As String)
Dim bo0 As Boolean
Dim A As Object
Set A = CreateObject("Access.Application")
A.OpenCurrentDatabase DbPath
bo0 = FCN_CheckTblsExist(A, tableName)
MsgBox tableName & " Exists is " & bo0
Debug.Print tableName & " Exists is " & bo0
A.Quit
Set A = Nothing
End Function
Note I didn't include any provision to check whether the DbPath database exists before attempting to open it. So you will get an error if you give it a path for a database which does not exist.
DAO Reference Issues:
DAO 3.6 was the last of the older DAO series. It only supports the older MDB type databases. When Access 2007 introduced the ACCDB database type, a new DAO library (Access database engine Object Library, sometimes referred to as ACEDAO) was introduced. In addition to supporting ACCDB databases, ACEDAO can also support the older MDB types.
When setting references, don't attempt to choose both.
Here is a screenshot of my project references:
When I examine my project references in the Immediate window, notice that ACEDAO is even referred to as just DAO. I also ran the callFCN_CheckTblsExist procedure to demonstrate it works without a DAO 3.6 reference:
That was all based on Access 2010. You're using Access 2013, so your ACEDAO version number may be different, but everything else should be the same.
Here are a couple of solutions along with a much simpler way to check if a table exists:
Workspace/Database; (much faster than using Application)
Function TestFunction_DataBase()
Dim ws As Workspace
Dim db As Database
Set ws = CreateWorkspace("", "admin", "", "dbUseJet")
Set db = ws.OpenDatabase("the db path", , , CurrentProject.Connection)
MsgBox TdefExists_DataBase(db, "the table name")
db.Close
ws.Close
Set db = Nothing
Set ws = Nothing
End Function
Function TdefExists_DataBase(ac As Database, strTableName As String) As Boolean
'check to see if table exists
On Error GoTo ErrHandler
Dim strBS As String
strBS = ac.TableDefs(strTableName).Name
TdefExists_DataBase = True
Exit Function
ErrHandler:
TdefExists_DataBase = False
End Function
Application:
Function TestFunction_Application()
Dim ac As New Access.Application
ac.OpenCurrentDatabase "the db path"
MsgBox TdefExists_Application(ac, "the table name")
ac.Quit
Set ac = Nothing
End Function
Function TdefExists_Application(ac As Access.Application, strTableName As String) As Boolean
'check to see if table exists
On Error GoTo ErrHandler
Dim strBS As String
strBS = ac.CurrentDb.TableDefs(strTableName).Name
TdefExists_Application = True
Exit Function
ErrHandler:
TdefExists_Application = False
End Function
Within the Current Database:
Function TdefExists(strName As String) As Boolean
'check to see if query exists
On Error GoTo ErrHandler
Dim strBS As String
strBS = CurrentDb.TableDefs(strName).Name
TdefExists = True
Exit Function
ErrHandler:
TdefExists = False
End Function

errors when exporting database to other computers

I have created a data base that comes in an installer that runs as an epos system.
On installing it on other computers, I get a large number of errors all saying that something is missing. the file runs perfectly on my computer, but the errors stop anything from working on other computers....
the errors are as follows. each has its own popup box.
broken reference to excel.exe version 1.7 or missing.
acwztool.accde missing
npctrl.dll v4.1 missing
contactpicker.dll v1.0 missing
cddbcontolwinamp.dll v1.0 missing
cddbmusicidwinamp.dll v1.0 missing
colleagueimport.dll v1.0 missing
srstsh64.dll missing
I feel like this may because I altered the module vba library referencing so that I could run a vba code that uses excel, unfortunatly i have forgotten which librarys i have added
if it helps, the code that I added which required new references is below
Public Sub SalesImage_Click()
Dim rst As ADODB.Recordset
' Excel object variables
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Dim i As Integer
On Error GoTo HandleErr
' excel aplication created
Set xlApp = New Excel.Application
' workbook created
Set xlBook = xlApp.Workbooks.Add
' set so only one worksheet exists
xlApp.DisplayAlerts = False
For i = xlBook.Worksheets.Count To 2 Step -1
xlBook.Worksheets(i).Delete
Next i
xlApp.DisplayAlerts = True
' reference the first worksheet
Set xlSheet = xlBook.ActiveSheet
' naming the worksheet
xlSheet.name = conSheetName
' recordset creation
Set rst = New ADODB.Recordset
rst.Open _
Source:=conQuery, _
ActiveConnection:=CurrentProject.Connection
With xlSheet
' the field names are imported into excel and bolded
With .Cells(1, 1)
.Value = rst.Fields(0).name
.Font.Bold = True
End With
With .Cells(1, 2)
.Value = rst.Fields(1).name
.Font.Bold = True
End With
' Copy all the data from the recordset into the spreadsheet.
.Range("A2").CopyFromRecordset rst
' Format the data the numbering system has been extended to encompas up to 9,999,999 sales to cover all posibilities of sales since the last stock take
.Columns(1).AutoFit
With .Columns(2)
.NumberFormat = "#,###,###"
.AutoFit
End With
End With
' Create the chart.
Set xlChart = xlApp.Charts.Add
With xlChart
.ChartType = xl3DBarClustered
.SetSourceData xlSheet.Cells(1, 1).CurrentRegion
.PlotBy = xlColumns
.Location _
Where:=xlLocationAsObject, _
name:=conSheetName
End With
'the reference must be regotten as it is lost
With xlBook.ActiveChart
.HasTitle = True
.HasLegend = False
With .ChartTitle
.Characters.Text = conSheetName & " Chart"
.Font.Size = 16
.Shadow = True
.Border.LineStyle = xlSolid
End With
With .ChartGroups(1)
.GapWidth = 20
.VaryByCategories = True
End With
.Axes(xlCategory).TickLabels.Font.Size = 8
.Axes(xlCategoryScale).TickLabels.Font.Size = 8
End With
With xlBook.ActiveChart
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Product"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Sales"
End With
'format the size and possition of the chart
With xlBook.ActiveChart
.Parent.Width = 800
.Parent.Height = 550
.Parent.Left = 0
.Parent.Top = 0
End With
'this displays the chart in excel. excel must be closed by the user to return to the till system
xlApp.Visible = True
ExitHere:
On Error Resume Next
'this cleans the excel file
rst.Close
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Exit Sub
HandleErr:
MsgBox Err & ": " & Err.Description, , "There has been an error!"
Resume ExitHere
End Sub
Deployment should be less troublesome if you remove your project's Excel reference and use late binding for Excel objects.
A downside is you lose the benefit of Intellisense during development with late binding. However it's very easy to switch between early binding during development and late binding for production. Simply change the value of a compiler constant.
In the module's Declarations section ...
#Const DevStatus = "PROD" 'PROD or DEV
Then within the body of a procedure ...
#If DevStatus = "DEV" Then
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = New Excel.Application
#Else ' assume PROD (actually anything other than DEV)
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Set xlApp = CreateObject("Excel.Application")
#End If
With late binding your code will need to use the values of Excel constants rather than the constants names. Or you can define the named constants in the #Else block for production use then continue to use them by name in your code.
I don't know what all those other reference are. Suggest you take a copy of your project, remove all those references and see what happens when you run Debug->Compile from the VB Editor's main menu. Leave any unneeded references unchecked. And try late binding for the rest. I use only 3 references in production versions of Access applications: VBA; Access; and DAO.