LarryP said:
Dirk, thanks for the info. That sound promising, yes, I'd appreciate the
code when you have a moment.
Okay, here's the code. You'll see it's not very complicated, but it's not
that well documented, either. Ask questions about anything you don't
understand.
Watch out for lines wrapped by the newsreader -- you'll need to fix those
yourself.
'------ start of code ------
Option Compare Database
Option Explicit
' Class clsWorkDB creates a temporary work-database and allows the user to
create,
' link to, and manipulate temporary tables in the work database. A new work
database
' is created for each instance of this class. All tables are unlinked and
the work
' database is deleted when that instance is destroyed.
' Copyright 2002-2009 Dirk Goldgar and DataGnostics LLC. All rights
reserved.
' Permission is granted to use this code in your application, provided
' that the copyright notice remains intact.
' Procedures TempDir and TempFile in this module were written by Terry Kreft
' and posted for public use. Neither Dirk Goldgar nor DataGnostics claims
' copyright on these procedures.
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias
"GetTempFileNameA" _
(ByVal lpszPath As String, ByVal lpPrefixString As String, _
ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private mdbWorkDB As DAO.Database ' This is the work database we'll be
using.
' We create the database file when the
class
' is instantiated and set this reference
to it.
' When the instance is destroyed, we
delete the
' file.
Private mblnEchoStatus As Boolean ' Should we assume Application.Echo is
on (True) or off?
Private mstrCallWhenEmpty As String ' If not empty, this is the name of a
public
' procedure to be called (via
Application.Run)
' when a call to this class's DropTable
method
' leaves the work database empty of
tables. The
' assumption is that the called
procedure will
' destroy this instance of the class.
Private mlngSystemTableCount ' When the work database is created, we
set this
' to the number of tables in the
database before
' any user tables have been created.
That way,
' we'll know when the last user table
has been
' deleted.
Public Sub DropWorkTable(TableName As String)
' Drop a table in the work database, and the local table that is linked
to it.
Dim dbCurr As DAO.Database
Dim tdf As DAO.TableDef
Dim strErrMsg As String
Dim strLinkedTable As String
Dim lngError As Long
Dim lngTDFCount As Long
' Make sure that the table whose name we were passed exists as a linked
table in
' the current database, and that it is linked to a table of the same
name in
' the work database.
Set dbCurr = DBEngine(0)(0)
dbCurr.TableDefs.Refresh
On Error Resume Next
Set tdf = dbCurr(TableName)
lngError = Err.Number
On Error GoTo 0
Select Case lngError
Case 0
' The table exists; so far so good. Is it linked to our work
database?
If tdf.Connect <> ";DATABASE=" & mdbWorkDB.Name Then
strErrMsg = "Can't delete work table '" & TableName & _
"' -- this table is not linked to the work
database."
Else
' Just in case, get the source-table name from the tabledef.
strLinkedTable = tdf.SourceTableName
End If
Case 3265
' Oops, the table doesn't exist.
strErrMsg = "Can't delete work table '" & TableName & _
"' -- this table does not exist."
Case Else
' Some other error occurred, which is going to mess us up.
strErrMsg = "Can't delete work table '" & TableName & _
"' -- error " & lngError & " accessing table in the
current database."
End Select
Set tdf = Nothing
If Len(strErrMsg) > 0 Then
Set dbCurr = Nothing
Err.Raise 5, strErrMsg
Else
' Delete the table from the current database.
dbCurr.TableDefs.Delete TableName
Set dbCurr = Nothing
RefreshDatabaseWindow
' Delete the table from the work database.
With mdbWorkDB.TableDefs
.Delete strLinkedTable
.Refresh
' Capture the updated tabledef count.
lngTDFCount = .Count
End With
' We may have been given the name of a public procedure to
' call when the work database has no more user tables.
If lngTDFCount <= mlngSystemTableCount Then
If Len(mstrCallWhenEmpty) > 0 Then
Application.Run mstrCallWhenEmpty
End If
End If
End If
End Sub
Public Property Let EchoStatus(NewValue As Boolean)
mblnEchoStatus = NewValue
End Property
Public Property Get EchoStatus() As Boolean
EchoStatus = mblnEchoStatus
End Property
Public Property Get Name() As String
Name = mdbWorkDB.Name
End Property
Private Function TempDir() As String
' Return path to system temp directory.
' Written by Terry Kreft.
Dim lngRet As Long
Dim strTempDir As String
Dim lngBuf As Long
strTempDir = String$(255, 0)
lngBuf = Len(strTempDir)
lngRet = GetTempPath(lngBuf, strTempDir)
If lngRet > lngBuf Then
strTempDir = String$(lngRet, 0)
lngBuf = Len(strTempDir)
lngRet = GetTempPath(lngBuf, strTempDir)
End If
TempDir = left(strTempDir, lngRet)
End Function
Private Function TempFile( _
Create As Boolean, _
Optional lpPrefixString As Variant, _
Optional lpszPath As Variant) _
As String
'Creates and/or returns the name of a unique temp file
'
'<Create> determines whether to just return a filename or
'to create the file.
'
'<lpPrefixString> defines the first three letters of the
'temp filename; if left blank, will use "tmp".
'
'<lpszPath> defines the directory path to the temporary file;
'if left blank, will use the system temp directory setting.
' Written by Terry Kreft.
Dim lpTempFileName As String * 255
Dim strTemp As String
Dim lngRet As Long
If IsMissing(lpszPath) Then
lpszPath = TempDir
End If
If IsMissing(lpPrefixString) Then
lpPrefixString = "tmp"
End If
lngRet = GetTempFileName(lpszPath, lpPrefixString, 0, lpTempFileName)
strTemp = lpTempFileName
lngRet = InStr(lpTempFileName, Chr$(0))
strTemp = left(lpTempFileName, lngRet - 1)
If Create = False Then
Kill strTemp
Do Until Dir(strTemp) = "": DoEvents: Loop
End If
TempFile = strTemp
End Function
Public Property Let CallWhenEmpty(NewValue As String)
mstrCallWhenEmpty = NewValue
End Property
Private Sub Class_Initialize()
Dim strWorkDBName As String
Dim strWorkDBFolder As String
Dim wrkDefault As Workspace
strWorkDBName = TempFile(False)
' Get default Workspace.
Set wrkDefault = DBEngine.Workspaces(0)
'Create a new temp database
Set mdbWorkDB = wrkDefault.CreateDatabase(strWorkDBName, dbLangGeneral)
Set wrkDefault = Nothing
mblnEchoStatus = True ' default value for EchoStatus property is True
' Record the number of tables in the database before no user tables
' have been created. This will be the count of system tables, but
' we have to add 1 to it because another system table,
MSysAccessStorage,
' will be added the first time Access creates a table in the database.
mlngSystemTableCount = mdbWorkDB.TableDefs.Count + 1
End Sub
Private Sub Class_Terminate()
Dim dbCurr As DAO.Database
Dim tdf As DAO.TableDef
Dim strWorkDBName As String
Dim strConnect As String
Dim lngT As Long
If mdbWorkDB Is Nothing Then
Exit Sub
End If
' Capture the name of the work database before closing it.
strWorkDBName = mdbWorkDB.Name
' Remove all tabledefs in the current database that are linked to the
' work database.
Set dbCurr = DBEngine(0)(0)
dbCurr.TableDefs.Refresh
strConnect = ";DATABASE=" & strWorkDBName
With dbCurr.TableDefs
For lngT = (.Count - 1) To 0 Step -1
Set tdf = .Item(lngT)
If tdf.Connect = strConnect Then
.Delete tdf.Name
End If
Set tdf = Nothing
Next lngT
End With
Set dbCurr = Nothing
RefreshDatabaseWindow
' Close and destroy the work database object.
mdbWorkDB.Close
Set mdbWorkDB = Nothing
' Erase the work database file.
Kill strWorkDBName
End Sub
Public Sub MakeWorkTable(TableName As String, TemplateName As String)
' Create a table in the work database and a table linked to it in the
current database,
' modeled on a specified, existing table.
Dim dbCurr As DAO.Database
Dim tdf As DAO.TableDef
Dim lngError As Long
' Check whether the table to be created exists in the current database,
and if so
' whether it is a linked table.
Set dbCurr = DBEngine(0)(0)
dbCurr.TableDefs.Refresh
On Error Resume Next
Set tdf = dbCurr(TableName)
lngError = Err.Number
On Error GoTo 0
Select Case lngError
Case 0
' The table exists. If it's a linked table, we are willing to
delete it.
If Len(tdf.Connect) > 0 Then
dbCurr.TableDefs.Delete TableName
Else
Set tdf = Nothing
Set dbCurr = Nothing
Err.Raise 5, "Can't create work table '" & TableName & _
"' -- this table already exists in the current
database."
End If
Case 3265
' The table doesn't exist. That's what we hoped.
Case Else
' Some other error occurred, which is going to mess us up.
Set tdf = Nothing
Set dbCurr = Nothing
Err.Raise 5, "Can't create work table '" & TableName & _
"' -- error " & lngError & " accessing table in
the current database."
End Select
Set tdf = Nothing
' Create the temp table in the work database
DoCmd.TransferDatabase acExport, "Microsoft Access", mdbWorkDB.Name,
acTable, TemplateName,
TableName, True
Application.Echo mblnEchoStatus ' Force Access to clear "Verifying
system objects ..." status bar message
mdbWorkDB.TableDefs.Refresh
' Create a linked table in this database, linked to the table in the
work database.
Set tdf = dbCurr.CreateTableDef(TableName)
tdf.Connect = ";DATABASE=" & mdbWorkDB.Name
tdf.SourceTableName = TableName
dbCurr.TableDefs.Append tdf
Set tdf = Nothing
dbCurr.TableDefs.Refresh
RefreshDatabaseWindow
MakeWorkTable_Exit:
Set dbCurr = Nothing
Exit Sub
End Sub
'------ end of code ------
