Public Function CompactBase(ByRef CnxAdo As ADODB.Connection, Optional iJetType As Integer = 5) As Boolean
'********************************************************/
' Référence projet à rajouter : /
' Microsoft Jet And Replication Objects 2.6 Library /
'********************************************************/
CompactBase = False
Dim sPathSrc As String
Dim sPathDest As String
Dim sPassWord As String
Dim Jro As New JetEngine
' la cnx doit être active
If Not (CnxAdo Is Nothing) Then
If Not (Cnx.State = adStateClosed) Then
' chemins & pass
sPathSrc = CnxAdo.Properties.Item(7)
sPathDest = sPathSrc & "_" & Format(Now, "DDMMYYHHNNSS") & ".mdbBAK"
sPassWord = CnxAdo.Properties.Item(63)
' on ferme la base
CnxAdo.Cancel
CnxAdo.Close
' compactage
On Error Resume Next
Jro.CompactDatabase "Provider=Microsoft.jet.OLEDB.4.0;Data Source=" & sPathSrc & ";Jet OLEDB:Database Password=" & sPassWord & ";Jet OLEDB:Engine Type=" & CStr(iJetType) & ";", _
"Provider=Microsoft.jet.OLEDB.4.0;Data Source=" & sPathDest & ";Jet OLEDB:Database Password=" & sPassWord & ";Jet OLEDB:Engine Type=" & CStr(iJetType) & ";"
' pas d'erreur, on renomme, on reconnecte, et retour OK
If Err.Number = 0 Then
On Error GoTo 0
Kill sPathSrc
Name sPathDest As sPathSrc
CompactBase = True
CnxAdo.Open
End If
End If
End If
' libère
Set Jro = Nothing
End Function