Public Sub CompactRepairViaExternalScript()

    Dim vbscrPath As String

    vbscrPath = CurrentProject.Path & "\CRHelper.vbs"

    If Dir(CurrentProject.Path & "\CRHelper.vbs") <> "" Then

        Kill CurrentProject.Path & "\CRHelper.vbs"

    End If

    Dim vbStr As String

    vbStr = "dbName = """ & CurrentProject.FullName & """" & vbCrLf & _

    "resumeFunction = ""ResumeBatch""" & vbCrLf & _

    "Set app = CreateObject(""Access.Application"")" & vbCrLf & _

    "Set dbe = app.DBEngine" & vbCrLf & _

    "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _

    "On Error Resume Next" & vbCrLf & _

    "Do" & vbCrLf & _

    "If Err.Number <> 0 Then Err.Clear" & vbCrLf & _

    "WScript.Sleep 500" & vbCrLf & _

    "dbe.CompactDatabase dbName, dbName & ""_1""" & vbCrLf & _

    "errCount = errCount + 1" & vbCrLf & _

    "Loop While err.Number <> 0 And errCount < 100" & vbCrLf & _

    "If errCount < 100 Then" & vbCrLf & _

    "objFSO.DeleteFile dbName" & vbCrLf & _

    "objFSO.MoveFile dbName & ""_1"", dbName" & vbCrLf & _

    "app.OpenCurrentDatabase dbName" & vbCrLf & _

    "app.UserControl = True" & vbCrLf & _

    "app.Run resumeFunction" & vbCrLf & _

    "End If" & vbCrLf & _

    "objFSO.DeleteFile Wscript.ScriptFullName" & vbCrLf

    Dim fileHandle As Long

    fileHandle = FreeFile

    Open vbscrPath For Output As #fileHandle

    Print #fileHandle, vbStr

    Close #fileHandle

    Dim wsh As Object

    Set wsh = CreateObject("WScript.Shell")

    wsh.Run """" & vbscrPath & """"

    Set wsh = Nothing

    Application.Quit

End Sub