---Soumis par Dev Ashish---

Utilitaire VB5 pour compacter une base de données Access 97.

    Voici un petit utilitaire VB5 qui vous permet de compacter la  base de données 97 depuis un programme qui y est exécuté.

    Télécharger mdbCompact.zip (9,454 bytes)

Comme toute version 1.0, mdbCompact risque d'avoir encore des bugs. J'ai effectué des tests sous Windows NT 4 et sous Windows 95.  Si vous trouvez des bugs ou si vous avez des suggestions, s'il-vous-plaît, m'envoyer un  email.

L'INFORMATION PRÉSENTÉE DANS CE DOCUMENT ET DANS L'UTILITAIRE MDBCOMPACT SONT SOUMIS TEL QUEL, SANS GARANTIE EXPRESSE OU IMPLICITE. L'UTILISATEUR ASSUME TOUT RISQUE ENCOURU PAR L'UTILISATION DE CE LOGICIEL.

Ó Dev Ashish (1998), All Rights Reserved

pour utiliser mdbCompact,  vous devez avoir soit  VB5 installé sur votre machine, soit avoir les fichiers "runtime" requis.  Si vous n'avez pas VB, vous pouvez téléchrger les fichiers requis pour utiliser cet utilitaire depuis Microsoft.

  Msvbvm50.exe (size: 1,307,480 bytes)

qui installe les fichiers suivants, inclus avec  Visual Basic Service Pack 2 and Service Pack 3:

   FILE            VERSION
   --------------------------
   MSVBVM50.DLL    05.00.4319
   OLEAUT32.DLL    2.20.4118
   OLEPRO32.DLL    5.0.4118
   STDOLE2.TLB     2.20.4118
   ASYCFILT.DLL    2.20.4118
   COMCAT.DLL      4.71

    Pour exéduter cet utilitaire, fournir  Currentdb.Name comme argument à la ligne de commande, depuis le code:

'******************** Code Begin ****************
Sub sTestmdbCompact()
Dim x
Dim strFolder As String
    strFolder = CurrentDBDir
    x = Shell(strFolder & "mdbCompact.exe " & CurrentDb.Name, vbNormalFocus)
End Sub

'Code courtesy of
'Terry Kreft
Function CurrentDBDir() As String
Dim strDBPath As String
Dim strDBFile As String
    strDBPath = CurrentDb.Name
    strDBFile = Dir(strDBPath)
    CurrentDBDir = Left(strDBPath, InStr(strDBPath, strDBFile) - 1)
End Function
'******************** Code End ****************

The code in the VB5 app itself is straight forward.  Here's what happens in the background.

'******************** Code Begin ****************
'
Option Explicit
Private Const mcFILENOTEXIST = vbObjectError + 10
Private Const mcACCESSNOTRUNNING = vbObjectError + 20
Private Const mcNOCOMMANDLINE = vbObjectError + 30
Private Const mcSave = 1

Private mobjAccess As Object

Private Sub Form_Load()
Dim stmdbName As String
Dim stMsg As String
Dim stNewName As String
Dim stTmp As String, stFileOnly As String

    On Error GoTo PROC_ERR
    stmdbName = Command
    stFileOnly = Dir(stmdbName)
    If stmdbName = vbNullString Then Err.Raise mcNOCOMMANDLINE
    If Len(Dir(stmdbName)) = 0 Then Err.Raise mcFILENOTEXIST
    If Not fIsAppRunning("Access") Then Err.Raise mcACCESSNOTRUNNING
    
    Load frmWait
    frmWait.Visible = True
    frmWait.lblStatus.Caption = "Compacting " & stFileOnly & "....."
    frmWait.Refresh
    
    Set mobjAccess = GetObject(, "Access.Application.8")
    
    stNewName = TempFile(False)
    With mobjAccess.application
        Call sCloseAllObjects
        .CloseCurrentDatabase
        DoEvents
        DBEngine.CompactDatabase stmdbName, stNewName
        DoEvents
        Kill stmdbName
        DoEvents
        FileCopy stNewName, stmdbName
        Do While Len(stmdbName) = 0: DoEvents:  Loop
        .opencurrentdatabase stmdbName
        Kill stNewName
    End With

PROC_EXIT:
    Set mobjAccess = Nothing
    Unload frmWait
    Unload Me
  Exit Sub
  
PROC_ERR:
    Select Case Err
        Case mcNOCOMMANDLINE:
            stMsg = "Missing Command Line.  Terminating!"
            MsgBox stMsg, vbCritical + vbOKOnly, "No mdb name found!"
        Case mcFILENOTEXIST:
            stMsg = "The filename you specified" & vbCrLf
            stMsg = stMsg & stmdbName & vbCrLf
            stMsg = stMsg & "doesn't exist.  Please  check the filename and try again!"
            MsgBox stMsg, vbCritical + vbOKOnly, "File not found"
            
        Case mcACCESSNOTRUNNING:
            stMsg = "The mdbCompact utility requires Access to be running!"
            stMsg = stMsg & vbCrLf & "Please confirm that Access is currently running and try again."
            MsgBox stMsg, vbExclamation + vbOKOnly, "Access instance not found"
        
        Case 429:
            stMsg = "The mdbCompact utility couldn't locate Access instance!"
            MsgBox stMsg, vbExclamation + vbOKOnly, "Access instance not found"
                
        Case Else:
            MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
                "Unknown Error"
    End Select
  Resume PROC_EXIT
End Sub

Sub sCloseAllObjects()
Dim i As Integer, ctr As Object, j As Integer
Dim db As Object
Dim astObj(0 To 5) As String
    astObj(0) = "Tables"
    astObj(1) = "Queries"
    astObj(2) = "Forms"
    astObj(3) = "Reports"
    astObj(4) = "Scripts"
    astObj(5) = "Modules"
    On Error Resume Next
    With mobjAccess
        Set db = .currentdb
        For i = 0 To 5
            Set ctr = db.Containers(astObj(i))
            For j = 0 To ctr.Documents.Count - 1
                .DoCmd.Close i, ctr.Documents(j).Name, mcSave
            Next j
        Next i
    End With
End Sub
'******************** Code End ****************