Okay, here is it in VB6. Watch for wrapping.
Reference: Microsoft Jet and Replication Objects 2.6 Library
Here's the VB6 function that actually does the compacting:
Private Function compactDB(ByVal strSourcePath As String, _
ByVal strDestPath As String) As Boolean
On Error GoTo ErrorHandler
'this is the routine that actually compacts the database
Dim JRO As New JRO.JetEngine
' Source and Destination connection path
Dim strDBSource As String, strDBDest As String
DoEvents
compactDB = False
strDBSource = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
strSourcePath & _
";Jet OLEDB
atabase Password=sp1derman"
strDBDest = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
strDestPath & " ;Jet OLEDB:Engine Type=5" & _
";Jet OLEDB
atabase Password=sp1derman"
JRO.CompactDatabase strDBSource, strDBDest
compactDB = True
ExitHere:
Exit Function
ErrorHandler:
Select Case Err.Number
Case Else
Call HandleUnexpectedError("basCompact/compactDB", Err.Number,
Err.Description)
End Select
Resume ExitHere
End Function
Here's how I use it, in case you're interested. OTW just ignore this.
I keep a file in the same folder as my database, called "xshutdown.txt".
When I want to kick people out or keep them out, I rename it shutdown.txt.
On startup, the application checks to see if "shutdown.txt" is there before
opening the database, and if it is, it doesn't let the user run the app.
I also have a timer that checks every 2 minutes to see if the file has
appeared, and if it has, it kicks them out of the app.
I had a lot of users, and this way, I could force them out if they left the
app running and went to lunch. Or I could keep them out when I was doing
maintenance on the database.
This routine checks for the "shutdown.txt" file, and if it's not there, it
creates a new one, so the users can't open the app while I'm compacting the
database. The content of the file is unimportant, but I put some comments
in there in case whoever took over the app after I left wanted to know what
it was.
gstrDBPath is the path to my database.
gstrUserGroup is which version of the app is running (several groups had
their own databases).
strDest = Left(gstrDBPath, _
InStrRev(gstrDBPath, ".mdb") - 1) & "_bkp.mdb"
'set source file
strSource = gstrDBPath
'path only
strPath = Left(gstrDBPath, InStrRev(gstrDBPath, "\"))
'look for shutdown file; if it's not there, create it
strShutDownFile = strPath & "xshutdown.txt"
strShutDownFileNew = strPath & "shutdown.txt"
If Dir(strShutDownFile) = vbNullString Then
'check and see if there is a shutdown.txt there,
' and if so, continue
'if there's not a shutdown.txt, create one
If Dir(strShutDownFileNew) = vbNullString Then
'create one
intFile = FreeFile(0)
Open strShutDownFileNew For Output Access Write As #intFile
Print #intFile, "If there is a file called shutdown.txt " & _
" in the same directory "
Print #intFile, "as the " & gstrUserGroup & _
"Tracking.mdb file (database)"
Print #intFile, "people running the " & _
gstrUserGroup & " Tracking Application"
Print #intFile, "will be kicked out, and will not " & _
" be allowed in, until the file is renamed."
Print #intFile, "This is used to get the users out so " & _
" the database can be compacted or backed up."
Close #intFile
End If
Else
Name strShutDownFile As strShutDownFileNew
End If
'if there's already a bkp file, delete it
If Dir(strDest) <> "" Then
Kill strDest
End If
'rename the production database to bkp
Name strSource As strDest
'do the compact from the bkp back to the new name
'so you will end up with with (for example)
' affiliatetracking.mdb and affiliatetracking_bkp.mdb
'if there is a failure somewhere, you can rename
' affiliatetracking_bkp back to affiliatetracking.
dtmStart = Now()
blnSuccessful = compactDB(strDest, strSource)
dtmEnd = Now()
If Not blnSuccessful Then
'delete the new one if it's there
' (it may have been partially compacted and messed up),
' then rename the old one back to production
If Dir(strSource) Then
Kill strSource
End If
Name strDest As strSource
End If
'rename the shutdown file back to its original name
' so the user can get back into the database
If Dir(strShutDownFileNew) <> vbNullString Then
Name strShutDownFileNew As strShutDownFile
End If
Hope that helps.
Robin S.
----------------------------------------