Access: persist a COM reference across Program Reset? - ms-access

Are there ways in Access VBA (2003) to cast a COM reference to an integer, and to call AddRef/Release? (which give the error "Function or interface marked as restricted, or the function uses an Automation type not supported in Visual Basic")
I'm using a third-party COM object which doesn't handle being instantiated twice in a single process (this is a known bug). I therefore thought of storing the reference as the caption of a control on a hidden form to protect it from Program Reset clearing all VB variables.
Edit: I think the cast to int can be done with the undocumented ObjPtr, and back again with the CopyMemory API, and AddRef/Release can be called implicitly. But is there a better way? Are add-ins protected from Program Reset?

Is the problem with surviving the code reset or is it that once the code is reset it can't be re-initialized?
For the first problem, wrap your top-level object in a function and use a STATIC variable internally to cache the reference. If the STATIC variable Is Nothing, re-initialize. Here's the function I use for caching a reference to the local database:
Public Function dbLocal(Optional bolInitialize As Boolean = True) +
As DAO.Database
' 2003/02/08 DWF added comments to explain it to myself!
' 2005/03/18 DWF changed to use Static variable instead
' uses GoTos instead of If/Then because:
' error of dbCurrent not being Nothing but dbCurrent being closed (3420)
' would then be jumping back into the middle of an If/Then statement
On Error GoTo errHandler
Static dbCurrent As DAO.Database
Dim strTest As String
If Not bolInitialize Then GoTo closeDB
retryDB:
If dbCurrent Is Nothing Then
Set dbCurrent = CurrentDb()
End If
' now that we know the db variable is not Nothing, test if it's Open
strTest = dbCurrent.Name
exitRoutine:
Set dbLocal = dbCurrent
Exit Function
closeDB:
If Not (dbCurrent Is Nothing) Then
Set dbCurrent = Nothing
End If
GoTo exitRoutine
errHandler:
Select Case err.Number
Case 3420 ' Object invalid or no longer set.
Set dbCurrent = Nothing
If bolInitialize Then
Resume retryDB
Else
Resume closeDB
End If
Case Else
MsgBox err.Number & ": " & err.Description, vbExclamation, "Error in dbLocal()"
Resume exitRoutine
End Select
End Function
Anywhere you'd either of these in code:
Dim db As DAO.Database
Set db = CurrentDB()
Set db = DBEngine(0)(0)
db.Execute "[SQL DML]", dbFailOnError
...you can replace the whole thing with:
dbLocal.Execute "[SQL DML]", dbFailOnError
...and you don't have to worry about initializing it when your app opens, or after a code reset -- it's self-healing because it checks the Static internal variable and re-initializes if needed.
The only caveat is that you need to make a call with the bolInitialize argument set to False when you shut down your app, as this cleans up the reference so there's no risk of your app hanging when it goes out of scope as the app closes.
For the other problem, I really doubt there's any solution within VBA, unless you can make an API call and kill the external process. But that's something of a longshot, I think.

Related

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

VBA - Using Typeof ... Is ADODB.Recordset Results in Compile Error

I am building a function with a set of supporting sub-functions to create ADOX.Catalog objects to help me build automation for Access database generation.
I like to use late-binding for my applications because my user base doesn't always have the same version of office applications, so I can't always rely on them having the same versions of the libraries I'm calling.
My public function accepts several objects as parameters, but I need to make sure they're actually ADODB.Recordset objects before I start processing them. I referred to the msdn article at https://msdn.microsoft.com/en-us/library/s4zz68xc.aspx to get started, and I'm trying to use If TypeOf ... Is ADODB.Recordset per the article's recommendation, but it generates the following error:
Compile error:
User-defined type not defined
Here is a snippet of my code. The first offending line is TypeOf adoRsColumns Is ADODB.Recordset:
Public Function ADOX_Table_Factory( _
ByVal strTblName As String, _
Optional ByVal adoRsColumns As Object, _
Optional ByVal adoRsIndexes As Object, _
Optional ByVal adoRsKeys As Object _
) As Object
'Init objects/variables.
Set ADOX_Table_Factory = CreateObject("ADOX.Table")
'Begin interactions with the new table object.
With ADOX_Table_Factory
.Name = strTblName
'Check if we've received an ADO recordset for the column(s).
If TypeOf adoRsColumns Is ADODB.Recordset Then
'Check that the recordset contains rows.
If Not (adoRsColumns.BOF And adoRsColumns.EOF) Then
'Loop through the column definitions.
Do
.Columns.Append ADOX_Column_Factory(adoRsColumns.Fields(0), adoRsColumns.Fields(1), adoRsColumns.Fields(2), adoRsColumns.Fields(3))
Loop Until adoRsColumns.EOF
End If
End If
My Googling has not yielded any results that have helped me get around this error. I have confirmed this code works if I set a reference to the ADO library. I have also confirmed, via the TypeName function, that the objects are identified by name as Recordset. If I replace TypeOf adoRsColumns Is ADODB.Recordset with TypeOf adoRsColumns Is Recordset, however, then the test evaluates false and the desired code doesn't execute. I haven't resorted to a string comparison to TypeName's output because, as stated in the MSDN article, TypeOf ... Is is faster.
Thanks in advance for any assistance!
Just to recap, without an ADO reference included in your project, you get a compile error at this line:
If TypeOf adoRsColumns Is ADODB.Recordset Then
Without the reference, VBA doesn't recognize ADODB.Recordset The situation is basically the same as if you tried to declare Dim rs As ADODB.Recordset without the reference. That declaration would trigger the same compile error.
There is no way to use ADODB.Recordset as a recognized type without the reference.
As an alternative approach, you could create a custom function to check whether the object supports a method or property which is available in an ADODB.Recordset but not in a DAO.Recordset
This one checks whether the recordset includes a Supports method. That method is available in an ADODB but not DAO Recordset.
Public Function IsAdoRecordset(ByRef pObject As Object) As Boolean
Const adAddNew As Long = 16778240
Dim lngTmp As Long
Dim blnReturn As Boolean
Dim strMsg As String
On Error GoTo ErrorHandler
blnReturn = False
If TypeName(pObject) = "Recordset" Then
lngTmp = pObject.Supports(adAddNew)
blnReturn = True
End If
ExitHere:
On Error GoTo 0
IsAdoRecordset = blnReturn
Exit Function
ErrorHandler:
Select Case Err.Number
Case 438 ' Object doesn't support this property or method
' leave blnReturn = False
Case Else
' notify user about any other error
strMsg = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure IsAdoRecordset"
MsgBox strMsg
End Select
Resume ExitHere
End Function

How to get count of db recordsets/references (to debug err #3048 - can't open more databases)?

I started getting error 3048 - Can't open more databases.
I seem to have tamed it by implementing a single, static database variable
in a function "dbLocal()" after David Fenton's example here.
I would still like to monitor the number of database references to see how close I am getting to the 2048 limit in Access. I have tried to use .Recordsets.Count but it always returns zero. How can I determine the reference/recordset count being used internally by Access?
One place I've tried to look at it is in the "dbLocal()" function. Stripped down to less-than-bare-minimum here (in my code I use Fenton's full example), I'm trying this:
Public Function dbLocal() As DAO.Database
Static dbCurrent As DAO.Database
If dbCurrent Is Nothing Then
Set dbCurrent = CurrentDb()
End If
Set CurDb = dbCurrent
Debug.Print dbCurrent.Recordsets.Count
End Function
but it always prints zero. Even if it worked, it's not what I really want, because (if I am understanding correctly) Access is maintaining its own accounting that includes references due to queries, combo-boxes, etc., whereas my static variable would only "know about" references due to VBA statements explicitly using this dbLocal() function.
Is there a way to get a peek at Access' internal accounting to know how close I might be to exhausting the 2048 maximum?
In case it matters: Windows XP Pro SP3; Access 2010 32-bit version 14.0.6024.1000 SP1 MSO 14.0.6112.5000.
One way to do it is to just keep opening recordsets until you get an error:
Function TablesAvailable() As Integer
Dim i As Integer, rs As DAO.Recordset, rsColl As Collection
On Error GoTo Err_TablesAvailable
Set rsColl = New Collection
Do While i < 4096
i = i + 1
Set rs = CurrentDb.OpenRecordset("SELECT 1")
rsColl.Add rs
Loop
Exit_TablesAvailable:
For Each rs In rsColl
rs.Close
Set rs = Nothing
Next rs
Exit Function
Err_TablesAvailable:
Select Case Err.Number
Case 3048 'Cannot open any more databases.
TablesAvailable = i
Case Else
MsgBox Err.Number & ": " & Err.Description
End Select
Resume Exit_TablesAvailable
End Function

Mail merge started by VBA in Access let Word open Database again

I'm working on a Access database which generates some mails with mail merge called from VBA code in the Access database. The problem is that if I open a new Word document and start the mail merge (VBA), Word opens the same Access database (which is already open) to get the data. Is there any way to prevent this? So that the already opened instance of the database is used?
After some testing I get a strange behavior: If I open the Access database holding the SHIFT-Key the mail merge does not open an other Access instance of the same database. If I open the Access database without holding the key, I get the described behavior.
My mail merge VBA code:
On Error GoTo ErrorHandler
Dim word As word.Application
Dim Form As word.Document
Set word = CreateObject("Word.Application")
Set Form = word.Documents.Open("tpl.doc")
With word
word.Visible = True
With .ActiveDocument.MailMerge
.MainDocumentType = wdMailingLabels
.OpenDataSource Name:= CurrentProject.FullName, ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, _
SQLStatement:="[MY QUERY]", _
SQLStatement1:="", _
SubType:=wdMergeSubTypeWord2000, OpenExclusive:=False
.Destination = wdSendToNewDocument
.Execute
.MainDocumentType = wdNotAMergeDocument
End With
End With
Form.Close False
Set Form = Nothing
Set word = Nothing
Exit_Error:
Exit Sub
ErrorHandler:
word.Quit (False)
Set word = Nothing
' ...
End Sub
The whole thing is done with Access / Word 2003.
Update #1
It would also help if someone could tell me what the exact difference is between opening Access with or without the SHIFT-Key. And if it is possible to write some VBA code to enable the "features" so if the database is opened without the SHIFT-Key, it at least "simulates" it.
Cheers,
Gregor
When I do mailmerges, I usually export a .txt file from Access and then set the mail merge datasource to that. That way Access is only involved in exporting the query and then telling the Word document to do the work via automation, roughly as follows:
Public Function MailMergeLetters()
Dim pathMergeTemplate As String
Dim sql As String
Dim sqlWhere As String
Dim sqlOrderBy As String
'Get the word template from the Letters folder
pathMergeTemplate = "C:\MyApp\Resources\Letters\"
'This is a sort of "base" query that holds all the mailmerge fields
'Ie, it defines what fields will be merged.
sql = "SELECT * FROM MailMergeExportQry"
With Forms("MyContactsForm")
' Filter and order the records you want
'Very much to do for you
sqlWhere = GetWhereClause()
sqlOrderBy = GetOrderByClause()
End With
' Build the sql string you will use with this mail merge
sql = sql & sqlWhere & sqlOrderBy & ";"
'Create a temporary QueryDef to hold the query
Dim qd As DAO.QueryDef
Set qd = New DAO.QueryDef
qd.sql = sql
qd.Name = "mmexport"
CurrentDb.QueryDefs.Append qd
' Export the data using TransferText
DoCmd.TransferText _
acExportDelim, , _
"mmexport", _
pathMergeTemplate & "qryMailMerge.txt", _
True
' Clear up
CurrentDb.QueryDefs.Delete "mmexport"
qd.Close
Set qd = Nothing
'------------------------------------------------------------------------------
'End Code Block:
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'Start Code Block:
'OK. Access has built the .txt file.
'Now the Mail merge doc gets opened...
'------------------------------------------------------------------------------
Dim appWord As Object
Dim docWord As Object
Set appWord = CreateObject("Word.Application")
appWord.Application.Visible = True
' Open the template in the Resources\Letters folder:
Set docWord = appWord.Documents.Add(Template:=pathMergeTemplate & "MergeLetters.dot")
'Now I can mail merge without involving currentproject of my Access app
docWord.MailMerge.OpenDataSource Name:=pathMergeTemplate & "qryMailMerge.txt", LinkToSource:=False
Set docWord = Nothing
Set appWord = Nothing
'------------------------------------------------------------------------------
'End Code Block:
'------------------------------------------------------------------------------
Finally:
Exit Function
Hell:
MsgBox Err.Description & " " & Err.Number, vbExclamation, APPHELP
On Error Resume Next
CurrentDb.QueryDefs.Delete "mmexport"
qd.Close
Set qd = Nothing
Set docWord = Nothing
Set appWord = Nothing
Resume Finally
End Function
To use this, you need to set up your Resources\Letters subfolder and put your mailmerge template word file in there. You also need your "base" query with the field definitions in your Access App (in the example, it is called MailMergeExportQry. But you can call it anything.
You also need to figure out what filtering and sorting you will do. In the example, this is represented by
sqlWhere = GetWhereClause()
sqlOrderBy = GetOrderByClause
Once you have got your head round those things, this is highly reusable.

MS Access (Jet) transactions, workspaces

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!