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 / Exemple :
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
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.