Dim VPath As String
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If MsgBox("Voulez vous enregistrer les modifications sur une clé USB ?", _
vbQuestion + vbYesNo, "ENREGITRE LES MODIFICATIONS") = vbYes Then
' MEssage pour la clé
MsgBox "Attention insérer une clé USB pour la sauvegarde ", vbInformation + vbOK
' Trouver la lettre de la clé
Call LettreCléUSB
' Si le chemin est vide c'est qu'il n'y a pas de clé
If VPath = "" Then
MsgBox "Aucune clé trouvée !" & vbCrLf & vbCrLf _
& "Sauvegarde et fermeture annulée"
Cancel = True
Exit Sub
End If
' Si une clé à été trouvée, sauvegarde dessus
ActiveWorkbook.SaveAs Filename:=VPath & "agenda - Sauvegarde.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End If
' Empècher le message d'erreur si on ne veut pas enregistrer
On Error Resume Next
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\SEV\Documents\comptes\agenda.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
On Error GoTo 0
End Sub
Sub LettreCléUSB()
' Active si ce n'est pas déjà fait
' la Référence Microsoft Scripting Runtime
On Error Resume Next
With ThisWorkbook.VBProject.References
Application.DisplayAlerts = False
.AddFromFile "C:\WINDOWS\SYSTEM32\scrrun.dll"
End With
Application.DisplayAlerts = True
On Error GoTo 0
Dim Fso As Object, FlgFind As Boolean, VTemp As String
[COLOR=blue] Dim Drv As Object[/COLOR]
[COLOR=blue] Const Removable = 1[/COLOR]
Set Fso = CreateObject("Scripting.FileSystemObject")
' Flag de la clé trouvée
FlgFind = False
VPath = ""
' Teste pour chaque lecteur
For Each Drv In Fso.Drives
'Empècher les erreurs lors de la recherche
On Error Resume Next
' Le disque amovible est de type = 1
If Drv.DriveType = Removable Then
VTemp = Drv.RootFolder
If Err.Number = 0 Then VPath = Drv.RootFolder
End If
On Error GoTo 0
Next
End Sub