"John Baker" <jo********@com cast.net> wrote in message
news:6g******** *************** *********@4ax.c om...
Anthony:
Thanks for your comments, I appreciate them. Unfortunately the DB and the
programs are
split, so that there is a back end and a front end. I don't know if this
impacts what you
advised, but I thought I should at least mention it,.
By the way, what is the "CompactOnClose " option, and how do I activate it?
Thanks again
John Baker
Hi John
Yes it does make a difference - in fact it was one of the first questions I
asked. The difference it makes is that you could be compacting either the
front or the back end. Normally, it is the back end which needs compacting
as this is what holds the data and which has the additions and deletions
that cause the bloat (the space is not automatically re-claimed after
records are deleted)
So, what you need to do is compact the back end from the front end - this is
something the compact on close cannot do for you. This, by the way, is
under Tools>Options>G eneral tab and simply compacts the database
automatically when you close it.
However, in your case, you should create a new module named "modCompact " and
cut and paste the following code into it. You need to alter one line where
you write in the name of any front-end linked table instead of:
"ReplaceThisWit hYourTableName"
Make sure it compiles and then save the database. You can now have a macro
with a step of RunCode where you write in the name of the function
=CompactBackEnd ()
I have tested this code, but I can't guarantee it, so test cautiously.
' *** Code Starts ***
Option Compare Database
Option Explicit
Private Const TABLE_NAME As String = "ReplaceThisWit hYourTableName"
'
'
Public Function CompactBackEnd( ) As Boolean
On Error GoTo Err_Handler
Dim strBackEndPath As String
Dim strBackEndDir As String
Dim strBackEndFile As String
Dim strTempPath As String
Dim strCopyPath1 As String
Dim strCopyPath2 As String
Dim strStartSize As String
Dim strStopSize As String
Dim strWarning As String
strBackEndPath = BackEndPath(TAB LE_NAME)
If Len(strBackEndP ath) > 0 Then
strBackEndFile = Dir(strBackEndP ath)
Else
MsgBox "Cannot locate datasource", vbCritical, _
"Compact and Repair Routine"
Exit Function
End If
If Len(strBackEndF ile) > 0 Then
strBackEndDir = Left$(strBackEn dPath, _
Len(strBackEndP ath) - Len(strBackEndF ile))
Else
MsgBox "Cannot locate datasource", vbCritical, _
"Compact and Repair Routine"
Exit Function
End If
strTempPath = strBackEndDir & "tmp" & strBackEndFile
strCopyPath1 = strBackEndDir & "tmpCopyDb1.mdb "
strCopyPath2 = strBackEndDir & "tmpCopyDb2.mdb "
strWarning = "A temporary file has been detected." & vbCrLf & _
"This may have come from a previous attempt " & _
"to compact and repair the database." & vbCrLf & _
"If you are sure this holds no useful data " & _
"then it may be deleted." & vbCrLf & "Otherwise rename " &
_
"or move the file to another location." & vbCrLf & vbCrLf &
_
"The current path is:" & vbCrLf
If Len(Dir(strTemp Path)) > 0 Then
MsgBox strWarning & strTempPath, vbCritical, _
"Compact and Repair Routine"
Exit Function
End If
If Len(Dir(strCopy Path1)) > 0 Then
MsgBox strWarning & strCopyPath1, vbCritical, _
"Compact and Repair Routine"
Exit Function
End If
If Len(Dir(strCopy Path2)) > 0 Then
MsgBox strWarning & strCopyPath2, vbCritical, _
"Compact and Repair Routine"
Exit Function
End If
Name strBackEndPath As strTempPath
strStartSize = GetFileSize(str TempPath)
FileCopy strTempPath, strCopyPath1
DBEngine.Compac tDatabase strCopyPath1, strCopyPath2
strStopSize = GetFileSize(str CopyPath2)
Name strCopyPath2 As strBackEndPath
Kill strCopyPath1
Kill strTempPath
MsgBox "Backup complete for:" & strBackEndPath & vbCrLf & _
"Compacted from: " & strStartSize & _
" to " & strStopSize, vbInformation, _
"Compact and Repair Routine"
CompactBackEnd = True
Exit_Handler:
Exit Function
Err_Handler:
MsgBox Err.Description , vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler
End Function
Private Function BackEndPath(str TableName As String) As String
On Error GoTo Err_Handler
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim strPath As String
Set dbs = CurrentDb
Set tdf = dbs.TableDefs(s trTableName)
If Len(tdf.Connect ) > 0 Then
strPath = Mid$(tdf.Connec t, 11)
End If
BackEndPath = strPath
Exit_Handler:
If Not tdf Is Nothing Then
Set tdf = Nothing
End If
If Not dbs Is Nothing Then
Set dbs = Nothing
End If
Exit Function
Err_Handler:
'No error message just return a zero-length string
Resume Exit_Handler
End Function
Private Function GetFileSize(str Path As String) As String
On Error GoTo Err_Handler
Dim intFile As Integer
Dim lngSize As Long
Dim sngSize As Single
Dim Digit As Byte
Dim strReturn As String
intFile = FreeFile
Open strPath For Binary Access Read As #intFile
lngSize = LOF(intFile)
Close #intFile
Select Case lngSize
Case Is > 1073741824
sngSize = lngSize / 1073741824
strReturn = "GB " & Format(sngSize, "###,###.00 0")
Case Is > 1048576
sngSize = lngSize / 1048576
strReturn = "MB " & Format(sngSize, "###,###.00 0")
Case Else
sngSize = lngSize / 1024
strReturn = "KB " & Format(sngSize, "###,###.00 0")
End Select
Digit = CByte(Right$(st rReturn, 1))
If Digit > 4 Then
Digit = Digit + 1
End If
strReturn = Left$(strReturn , Len(strReturn) - 2) & CStr(Digit)
If Right$(strRetur n, 3) = ".00" Then
strReturn = Left$(strReturn , Len(strReturn) - 3)
Else
If Right$(strRetur n, 1) = "0" Then
strReturn = Left$(strReturn , Len(strReturn) - 1)
End If
End If
strReturn = Mid$(strReturn, 4) & " " & Left$(strReturn , 2)
GetFileSize = strReturn
Exit_Handler:
Exit Function
Err_Handler:
MsgBox Err.Description , vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler
End Function
' *** Code Ends ***
