Compact or Copy a linked database to a new database

[Greg J]

Here is a function I have created that enables you to compact or copy a
linked database to a new database. I need to copy the linked database
to a website so I need to be able to create a compacted copy of the
database. As it was linked, it wouldnt let me do it from the front
end. As a result, I have come up with the following routine that does
the following:

1. Gets a list of all the tables that are currently linked to the BE
database to compact
2. Deletes the links to these tables
3. Compacts and copies the BE database to a new name in the same
folder as the BE database
4. Relinks the tables to the FE database

Unfortunately this is the only way I seem to be able to do it. I would
appreciate any advice and or feedback on the function.

** START OF CODE **************************
'this constant replaces ".mdb" in strDatabaseName
Public Const DATABASE_COPY_NAME = "_TEST.mdb"

'strDatabaseName is the full path and name of the linked BE database
Function createDatabaseCopy(strDatabaseName As String) As Boolean
On Error GoTo ErrorHandler

Dim db As DAO.Database
Dim tdf As DAO.TableDef

Dim strDBDestinationName As String
Dim colTbl As New Collection
Dim i As Integer

Set db = CurrentDb

'Add the names of the tables that are linked to the collection
For Each tdf In db.TableDefs
If tdf.Attributes = dbAttachedTable Then
If InStr(1, tdf.Connect, strDatabaseName, vbTextCompare) >
0 Then
colTbl.Add tdf.Name, tdf.Name
End If
End If
Next

'Delete the linked tables using the collection
For i = 1 To colTbl.Count
db.TableDefs.Delete colTbl(i)
Next
db.TableDefs.Refresh
Application.RefreshDatabaseWindow

strDBDestinationName = Replace(strDatabaseName, ".mdb",
DATABASE_COPY_NAME)

'Must remove the destination database if it exists prior to
compacting
If Not Dir(strDBDestinationName, vbNormal) = "" Then Kill
strDBDestinationName

DoEvents
DoEvents

'Now that links are removed, you can compact/copy the database
CompactDatabase strDatabaseName, strDBDestinationName

DoEvents
DoEvents

'relink the tables again using the collection
For i = 1 To colTbl.Count
DoCmd.TransferDatabase acLink, "Microsoft Access",
strDatabaseName, acTable, colTbl(i), colTbl(i)
Next

createDatabaseCopy = True

ExitPoint:
On Error Resume Next

db.TableDefs.Refresh
Application.RefreshDatabaseWindow

Set tdf = Nothing
Set db = Nothing

Exit Function

ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf &
"createDatabaseCopy" & vbCrLf & "modCopyDatabase"
Resume ExitPoint

End Function

** END OF CODE **************************

 

[Albert D.Kallal]

As long as your front end closes all tables, you do not have to worry
about, or touch the links.

So, to compact the back end (and, I do this all the time), you

1) close all tables
2) compact the file to a new file
3) copy this compacted file over the original..


DBEngine.CompactDatabase strBackEnd, strToNewFile

 

[Greg J]

so how do you "close all tables", can you provide the method you use to
do that please?

 

[Albert D.Kallal]

so how do you "close all tables", can you provide the method you use to
do that please?

You just make sure none are open!!! If you have code that opens a reocrdset,
you simply have to close it...

Most, if not all of us open a global reocrdset to the backend to "persist" a
connection (if you don't do this, you get very poor performance).

So, if you have any recordsets open, simply close them in code.

gblMyRecordSet.Close

So, if run try and compact, and it returns a error, then the uwer has a
form, or table open, or other users are in the database.....

You must instruct the user to try latter (in the case of other using hte
database), or instruct the user to close any open form, or table before
compacting can continue....

You can tell somthing is open if your compact fails.....

Here is m code that I use

Public Function Askmycompact()

' first close all reocrdsets...

If Forms.Count > 1 Then
MsgBox "You must close all forms before using this feature",
vbInformation, AppName
Exit Function
End If

If MsgBox("This compact feature reorganizes your data file for maximum
performance" & vbCrLf & _
"This feature should be used once a month" & vbCrLf & _
"This feature will also re-build your indexes." & vbCrLf &
vbCrLf & _
"Would you like to run a compact operation now?", vbQuestion +
vbYesNoCancel, "Repair and re-build Data") <> vbYes Then
Exit Function
End If

' On Error Resume Next

Call CloseAll

On Error GoTo 0
DoEvents

DoCmd.Close acForm, "frmMain" ' close the form this runs from!!!

If MyCompactDB = True Then

MsgBox "Compact Done - thank you!!", vbInformation, AppName

End If

DoCmd.OpenForm "frmMain"


End Function

Note how I have a routine called close all....
That routine simply closes all my global reocrdsets (there is really no way
to tell if any are open..you just have to clean this up yourself..

My closeall routine looks like

Public Sub CloseAll()

' close all open recordsets....
On Error Resume Next

gblRstGstRates.Close
Set gblRstGstRates = Nothing

gblRecRides.Close
Set gblRecRides = Nothing

tblLockRecords.Close
Set tblLockRecords = Nothing

End Sub

Each time I add a new global reocrdset that *might* be open, then I add the
code to the above close all routine....

Here is chopped down version of the compact code...

Public Function MyCompactDB(Optional strOFile As String = "") As Boolean

' compact to a db with a NEW extension of backend name + .bak
' for the extension...

Dim strbackFile As String
Dim strCurDir As String
Dim strToFile As String

On Error GoTo CompactDB_Error

strCurDir = CurrentProject.path & "\"

strToFile = Mid(strBackEnd, InStrRev(strBackEnd, "\") + 1)
strToFile = Left(strToFile, Len(strToFile) - 4)

If strOFile <> "" Then

' file name was passed...use that...
strToFile = strOFile

End If

strToFile = strCurDir & strToFile & ".bak"

If Len(Dir(strToFile)) > 0 Then
Kill strToFile
End If

' up to this point...no errors...switch to eror2..

On Error GoTo CompactDB_Error2
DBEngine.CompactDatabase strBackEnd, strToFile

' copy the compacted backup to production
FileCopy strToFile, strBackEnd

MyCompactDB = True

Exit Function

CompactDB_Error:

MsgBox "Unable to compact file" & vbCrLf & vbCrLf & _
"Error " & Err.Number & " (" & Err.Description & ")", vbCritical,
AppName


CompactDB_Error2:

If Err.Number = 3356 Then

MsgBox "There are other users in the Data File" & vbCrLf & _
"(or you have more then one copy of Rides running)" & vbCrLf &
_
vbCrLf & _
"All other users must exit before you can complete this data" &
vbCrLf & _
"Maintenace on your data file" & vbCrLf & vbCrLf & _
"Please try again later", vbExclamation, AppName
Else

MsgBox "Unable to compact file" & vbCrLf & vbCrLf & _
"Error " & Err.Number & " (" & Err.Description & ")",
vbCritical, AppName


End If


End Function

I also have a function called strBackEnd, and that simply returns the back
end name...

here is that function....

Function strBackEnd() As String

Dim mytables As TableDef

Dim strTempBack As String
Dim strFullPath As String
strFullPath = ""

For Each mytables In CurrentDb.TableDefs
If Left(mytables.Connect, 10) = ";DATABASE=" Then
strFullPath = Mid(mytables.Connect, 11)
Exit For
End If
Next mytables

strBackEnd = strFullPath

End Function