begin process at 2008 09 06 20:11:28
1 237 931 membres
313 nouveaux aujourd'hui
14 314 membres club

Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum.
Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !

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


Information sur la source

Catégorie :VBA Classé sous : compactage, sauvegarde, base, données, database Niveau : Initié Date de création : 16/05/2005 Date de mise à jour : 16/05/2005 11:36:45 Vu / téléchargé: 5 555 / 886

Note :
9 / 10 - par 2 personnes
9,00 / 10

  • 1

  • 2

  • 3

  • 4

  • 5

  • 6

  • 7

  • 8

  • 9

  • 10

Commentaire sur cette source (1)
Ajouter un commentaire et/ou une note

Description

Ce code aide l'utilisateur a choisir une base de donnée .MDB dans le chemin courant, faire le compactage et choisir sur quel disque la mettre (lecteur ZIP, Flash disque, CD ... ou autre) pour la sauvegarde.

Source

  • 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
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
Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Télécharger le zip

16 mai 2005 11:36:45 :
Rajout de la base GC.MDB dans le .ZIP
  • signaler à un administrateur
    Commentaire de MasterHack le 16/05/2005 14:30:32

    c bien,mais les test des passwords c po trop efficace com truc.9/10 ;)

Ajouter un commentaire

Pub



Appels d'offres

CalendriCode

Septembre 2008
LMMJVSD
1234567
891011121314
15161718192021
22232425262728
2930     

VS Express FR Gratuit !

VS Express en français et 100% gratuit !

Boutique

Boutique de goodies CodeS-SourceS