Public Function DbCompact(oldDb As String, Optional bakDb As String = "") As Integer

  'Needs Microsoft Jet and Replication Objects Library
  'Needs Microsoft ActiveX Data Objects Library
  'Needs Microsoft Scripting Runtime

  'Returns 0 if OK, -1 if FAIL

  DbCompact = -1

  On Error GoTo noDbOk

  Dim j As JetEngine
  Dim fso As FileSystemObject
  Dim jStr As String, newDb As String

  Set fso = New FileSystemObject
  If Not fso.FileExists(oldDb) Then Exit Sub

  Set j = New JetEngine

  jStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
  newDb = App.Path & "\tmpDb.mdb"

  j.CompactDatabase jStr & oldDb, jStr & newDb

  If Trim(bakDb) <> "" Then
    If fso.FileExists(bakDb) Then fso.DeleteFile bakDb
    fso.MoveFile oldDb, bakDb
  Else
    fso.DeleteFile oldDb
  End If
  fso.MoveFile newDb, oldDb

  DbCompact = 0

noDbOk:

  Set fso = Nothing
  Set j = Nothing

End Sub 

vb.net

1

VB6: Compact Access DB with ADO

Public Function DbCompact(oldDb As String, Optional bakDb As String = "") As Integer

  'Needs Microsoft Jet and Replication Objects Library
  'Needs Microsoft ActiveX Data Objects Library
  'Needs Microsoft Scripting Runtime

  'Returns 0 if OK, -1 if FAIL

  DbCompact = -1

  On Error GoTo noDbOk

  Dim j As JetEngine
  Dim fso As FileSystemObject
  Dim jStr As String, newDb As String

  Set fso = New FileSystemObject
  If Not fso.FileExists(oldDb) Then Exit Sub

  Set j = New JetEngine

  jStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
  newDb = App.Path & "\tmpDb.mdb"

  j.CompactDatabase jStr & oldDb, jStr & newDb

  If Trim(bakDb) <> "" Then
    If fso.FileExists(bakDb) Then fso.DeleteFile bakDb
    fso.MoveFile oldDb, bakDb
  Else
    fso.DeleteFile oldDb
  End If
  fso.MoveFile newDb, oldDb

  DbCompact = 0

noDbOk:

  Set fso = Nothing
  Set j = Nothing

End Sub 

copy | embed

• access, 
• ado, 
• database, 
• vb6