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


Const strDBDir = "C:\Inetpub\wwwroot\asptest"
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