COMPACTAGE ET SAUVEGARDE D'UNE BASE DE DONNÉE .MDB

Option Explicit
Dim passwords, mpasse, source
Dim base_de_donnees As Database
Dim tables As Variant
Dim i, j As Integer
Dim chaine As String

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
        If KeyCode = 13 Then
           If Shift = 0 Then
              KeyCode = 0
              SendKeys "{TAB}"
           Else
              KeyCode = 0
              SendKeys "+{TAB}"
           End If
        End If
End Sub

Private Sub Form_Load()
        source = "gc.mdb"
        passwords = Array("banana", "master", "ricky", "ibis", "marsouin", "alize")
        For i = 0 To UBound(passwords)
            On Error Resume Next
            mpasse = ";pwd=" & passwords(i)
            Set base_de_donnees = OpenDatabase(source, False, False, mpasse)
            If Err.Number <> 3031 Then
               Exit For
            End If
        Next
        If Err.Number <> 0 Then
           Select Case Err.Number
                  Case 3024
                       MsgBox "La base de données est Introuvable dans le Chemin spécifiée"
                  Case 3045
                       MsgBox "La base de données ne peut etre ouverte en ce moment " & vbCrLf & " car elle est ouverte en mode exclusif par un autre utilisateur "
           End Select
           Exit Sub
        End If
        Me.KeyPreview = True
        Me.Width = 6810
        Me.Height = 3525
        On Error Resume Next
        Set base_de_donnees = OpenDatabase(source, False, False, mpasse)
        'Si table de travail Inutile alors effacer avant le compactage
        tables = Array("distqte", "d1", "distval", "livconc", "flash1", "flash2", "flash3", "liqclt", "flashm", "anuclt", "cltmaj", "concess", "lstcp", "remise", "annubts", "boutclt", "boutemb", "compdgb", "creage", "encaissdgb", "etat104", "etatliquide", "etatttl", "etattva", "glivre", "listeclt", "listepro", "lstpieces", "releve", "regage", "regannu", "releveage", "wilclt", "chifaff", "pconc", "entete", "detail", "fstock", "tabfact", "fbt01")
        For i = 0 To UBound(tables)
            chaine = "DROP table " & tables(i) & ";"
            base_de_donnees.Execute chaine
        Next
        compact.Caption = "Compactage Base de Donnees"
        sauve.Caption = "Sauvegarde GC"
        sauve.Enabled = False
End Sub

Private Sub compact_Click()
        base_de_donnees.Close
        On Error Resume Next
        compact.Caption = " Compactage En cours ..."
        base_de_donnees.Close
        'Nom de la base GC.mdb au moment du compactage,
        'la mettre dans une base temporaire temp.mdb
        DBEngine.CompactDatabase "gc.mdb", "temp.mdb", , , ";pwd=banana"
        Kill "gc.mdb"
        FileCopy "temp.mdb", "gc.mdb"
        Kill "temp.mdb"
        compact.Caption = " Compactage Base de Donnees"
        MsgBox "Compactage de la Base de Données et Terminée"
End Sub

Private Sub sauve_Click()
        'base_de_donnees.Close
        Dim sources, destination, nombase
        sauve.Caption = " Sauvegarde En Cours ..."
        nombase = "gc.mdb"
        source = CurDir()
        destination = Drive1.Drive
        If Right(source, 1) <> "\" Then
           source = source & "\"
        End If
        FileCopy source & nombase, destination & nombase
        sauve.Caption = " Sauvegarde GC"
        MsgBox "Copie Terminée"
End Sub

Private Sub drive1_Change()
    Dim fs As Object
    Dim d, s, t
    Set fs = CreateObject("Scripting.FileSystemObject") 'Affecation d'un nouveau objet
    Set d = fs.GetDrive(Drive1.Drive) 'affectation d'un nouveau objet a un objet existant
    Select Case d.drivetype
        Case 0: t = "Inconnu"
        Case 1: t = "Amovible"
        Case 2: t = "Fixe"
        Case 3: t = "Réseau"
        Case 4: t = "CD-ROM"
        Case 5: t = "Disque RAM"
    End Select
    s = "Lecteur " & d.DriveLetter & ": - " & t
    If d.isready Then 'ISREADY Boolean (True OR False )
       File1.Path = Drive1.Drive
       File1.Refresh
    Else
'       s = s & vbCrLf & "Lecteur non prêt."
       s = "Lecteur non prêt."
       MsgBox s
       Drive1.Drive = "c:"
    End If
    sauve.Enabled = True
End Sub

Private Sub quitter_Click()
        Unload Me
End Sub

Télécharger le zip

16 mai 2005 11:36:45 :

Rajout de la base GC.MDB dans le .ZIP