Sub CompactDbase(sDbase As String, Aviso As Boolean)
Dim sBakDb As String
Dim db As Database
On Error Resume Next
If sDbase <> "" Then
Screen.MousePointer = vbHourglass
'try and open it in exclusive mode
Set db = OpenDatabase(sDbase, True)
If Err = 0 Then
'opened ok so close it
db.Close
'construct the correct .bak filename
sBakDb = Left$(sDbase, InStr(sDbase, ".")) & "BAK"
'give a chance to exit
If Aviso Then
gstrMsg = "Su base de datos " & sDbase & vbCrLf & " se copiará. " & sBakDb
If MsgBox(gstrMsg, vbOKCancel + vbExclamation, "Compactando la Base de Datos") = vbCancel Then
Screen.MousePointer = vbDefault
Exit Sub
End If
End If
'kill any existing .bak
If ExistFilename(sBakDb) Then
Kill (sBakDb)
End If
If Err <> 0 Then Err = 0 'err because no existing .bak
'copy original to sBakdb
FileCopy sDbase, sBakDb
If Err <> 0 Then
'call the generic error handler
GenErrorHandler "copiado de " & sDbase & " a " & sBakDb, Err, Error
Screen.MousePointer = vbDefault
Exit Sub
End If
'kill the existing database because can't compact into an existing one
If ExistFilename(sDbase) Then
Kill (sDbase)
End If
DoEvents
If Err = 0 Then
'deleted ok so compact it
'DBEngine.RepairDatabase sBakDb
DBEngine.CompactDatabase sBakDb, sDbase, dbLangGeneral, dbDecrypt
If Err <> 0 Then
'call the generic error handler
GenErrorHandler "compactado de la base de datos", Err.Number, Err.Description
Err = 0
'copy bakdb to original
FileCopy sBakDb, sDbase
If Err <> 0 Then
'call the generic error handler
GenErrorHandler "Error en copiado de " & sBakDb & " a " & sDbase, Err.Number, Err.Description
Screen.MousePointer = vbDefault
Exit Sub
End If
Else
If Aviso Then
MsgBox "Reparación y compactación completa.", vbOKOnly + vbExclamation, App.Title
End If
End If
Else
End If
Else
'call the generic error handler
GenErrorHandler "intento de abrir la base de datos de manera exclusiva.", Err, Error
End If
End If
Screen.MousePointer = vbDefault
End Sub