VBScript To Compact Access Databases

Windows Scripting Host

This script compacts all the Access database files (*.mdb) in a directory tree. The databases can not be password protected. See http://support.microsoft.com/default.aspx?scid=KB;en-us;230501 for additional information.

Please change the constant strDBDir to the full path of the directory in which your database files live.

If you run this script as an unattended job such as from the task scheduler or the AT service, then you can comment out the line below to stop the script from echoing what it is doing. You should also comment out this line if you are using WScript rather than CScript to run the script.

wscript.echo "Compacting " & dbPath

This script uses ADO and requires that Jet 4 engine be installed on the machine on which it is run. While there should be no problems using this script, please always when you first try any script run the script against backup files, or backup the originals before running the script for the first time.

' Compact Access DBs in the system DB directory
' 12-21-2001 Paul R. Sadowski

Const strDBDir = "c:\My Documents\Databases"
Dim arrDBs()
Dim idx, tmpext

Randomize
tmpext = "." & Int((999 - 100 + 1) * Rnd + lowerbound) & ".tmp"
idx = 0

Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")

GetFiles(strDBDir)
GetSubFolders(strDBDir)

for x = 0 to idx -1
CompactDB(arrDBs(x))
next

Set WshShell = Nothing
Set fso = Nothing

Function GetSubFolders(strFld)
Set objDBs = fso.GetFolder(strFld)
Set objDBFolders = objDBs.SubFolders

for each x in objDBFolders
GetFiles(x)
GetSubFolders(x)
next

Set objDBFolders = Nothing
Set objDBs = Nothing
end function

Function GetFiles(strPath)
Set objDBs = fso.GetFolder(strPath)
Set objFiles = objDBs.Files
for each f in objFiles
if Ucase(FileExt(f)) = "MDB" then
redim preserve arrDBs(idx+1)
arrDBs(idx) = f
idx = idx + 1
end if
next

Set objDBs = Nothing
Set objFiles = Nothing
end function

'Return the filename extension portion of a path/filename
function FileExt(FullPath)
dim x
dim tmpstring

x = Len(FullPath)
for y = x to 1 step -1
if mid(FullPath, y, 1) = "." then
tmpstring = mid(Fullpath, y+1)
exit for
end if
next
FileExt = tmpstring
end function

'Compact an access Database
Function CompactDB(dbPath)

wscript.echo "Compacting " & dbPath

Set fso1 = CreateObject("Scripting.FileSystemObject")
Set jro = CreateObject("Jro.JetEngine")
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbpath & ";Jet OLEDB:Database Password=", _
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbpath & tmpext & ";Jet OLEDB:Engine Type=5;Jet OLEDB:Database Password="
fso1.DeleteFile(DBpath)
fso1.MoveFile dbpath & tmpext, dbpath
set jro = Nothing
set fso1 = Nothing
End Function