Dirk Goldgar said:
You're welcome to the code, if you like; it's very simple.
Since Fred was so importunate, here it is. A whole bunch of lines are
going to be wrapped by the newsreader, and I'll leave it to you to
"unwrap them".
'----- start of module 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, 2003 Dirk Goldgar and DataGnostics. 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 module code -----
