Sauvegarde sur clef usb

Anonyme

Bonjour,

Je voudrais modifier un bout de code pour sauvegarder un répertoire sur clef usb.

A la fermeture du classeur, le classeur s'enregistre dans C:"xxx" ou x égale nom du classeur, et je voudrais aussi sauvegarder le répertoire qui contient le classeur sur clef usb.

Voici ce que j'ai:

' ---------bouton quitter Excel--------------

Private Sub FermerProg_Click()

Dim w

1 If Dir("K:\sav-prog", vbDirectory) <> "" Then

2 Application.DisplayAlerts = False

3 For Each w In Application.Workbooks

4 w.Save '---------Sauvegarde le classeur sur l'ordi --------

5 w.SaveAs "K:\sav-prog" & w.Name '----Sauvegarde le classeur sur la clef de sauvegarde ----

6 Next

7 Application.DisplayAlerts = True

8 mywav6 ' ceci exécute la macro qui est dans le module 5

9 Application.ScreenUpdating = True

10 Application.CommandBars.ActiveMenuBar.Enabled = True

11 Application.CommandBars("Formatting").Visible = True

12 Application.CommandBars("Standard").Visible = True

13 Application.DisplayFormulaBar = True

14 Application.DisplayScrollBars = True

15 ActiveSheet.Protect

16 Application.Quit

17 Exit Sub

18 Else

19 MsgBox "Vérifier que la clef soit bien en place"

20 End If

End Sub

je voudrais modifier la ligne 5 pour sauvegarder le répertoire et non le classeur.

Si quelq'un peut m'aider !!!

Merci par avance.

Peponne31

Question verrouillée. Cette question a été migrée à partir de la Communauté Support Microsoft. Vous pouvez voter pour indiquer si elle est utile, mais vous ne pouvez pas ajouter de commentaires ou de réponses ni suivre la question.

0 commentaires

Réponse acceptée par l’auteur de la question

Anonyme

Un autre fichier exemple : http://cjoint.com/?hnrc64cRFA

Tu enregistres le fichier dans le répertoire désiré.

Tu ouvres le fichier et tu cliques sur le bouton.

Tous les fichiers qui sont dans le même répertoire où tu as copié le fichier exemple

seront copiés sur ta clé dans un répertoire que la macro se chargera de créer au nom de "H2C_Ver_2"

Bien sûr, il faudra que ta clé soit connectée pour que cela réussisse

Tu n'as pas à regarder le code si cela te fait peur... tu n'as pas AUTRE CHOSE À FAIRE que les actions énumérées dans ce message.

Si cela fonctionne comme désiré, tu fais un copier-coller du code du module1 du classeur exemple vers un MODULE STANDARD que tu inséreras dans ton vrai classeur. (fenêtre VBA / barre des menus / insertion / module)

C'était mon dernier message sur ce fil.

MichD

"Peponne31" a écrit dans le message de groupe de discussion : *** Adresse électronique supprimée pour cause de confidentialité ***...

Bonjour à tous et merci pour vos réponses.

je suis perdu dans vos exemples, j'ai mi en place

le code de MichD de lundi à 5h45

que doit-je modifier dans:

Copie_répertoire_Source ThisWorkbook.Path , "H2C_Ver_2"

pour faire appel au module ?

Merci encore

Peponne31

0 commentaires

22 réponses supplémentaires

Anonyme

2010-07-12T07:49:33+00:00

Même chose : en pas à pas tout est OK sauf qu'il n'y a que création des rép et ss-rép, pas copie de fichiers (XL2000 WinXP)

J'ai le message "Un problème fut rencontré."

Le test de présence de clé USB est OK.

Ma machine doit-être ensorcelée, ou plus sûrement moi maladroit??.

Bonne nuit (ici 21:50)

J@@

Le 11/07/2010 19:45, MichD [MVP] a écrit :

| Sous XL2000 et Win XP

| Désolé, seuls les répertoires et ssrépertoires sont créés sur ma machine

Si tel est le cas, c'est étrange, je n'éprouve aucune difficulté sous Windows7 et Excel 2007

Je te remercie pour les tests que tu as effectués.

Si tu préfères l'usage des API de Windows....

La copie est quand même assez longue compte tenu que

la copie s'effectue vers un clé... Tu peux remplacer tout le

code du module du classeur exemple avec ceci :

'Déclaration des API dans le haut d'un module Standard

Type SHFILEOPSTRUCT

   hwnd As Long

   wFunc As Long

   pFrom As String

   pTo As String

   fFlags As Integer

   fAnyOperationsAborted As Boolean

   hNameMappings As Long

   lpszProgressTitle As String

End Type

Const FO_MOVE = 1

Const FO_COPY = 2

Const FO_DELETE = 3

Const FO_RENAME = 4

Const FOF_SILENT = 4

Const FOF_NOCONFIRMATION = 10

Private Declare Function SHFileOperationA Lib "Shell32.dll" _

   (lpFileOp As SHFILEOPSTRUCT) As Long

'-------------------------------------

Sub Test()

Dim LecteurSource As String, Prêt As Boolean

Dim LecteurDestination As String

Dim Chemin As String

Dim Répertoire As String

'Le répertoire où se retrouve le fichier

Répertoire = ThisWorkbook.Path& ""

'Si on désire effectuer la copie vers la clé vers un

'répertoire d'appellation différente que le répertoire sourcee :

'*************** À RENSEIGNER******************

Chemin = "toto\tutu\titi" ' à renseigner

'***********************************************

LecteurSource = Left(Répertoire, 3)

If Chemin = "" Then

   Chemin = Right(Répertoire, Len(Répertoire) - 3)

End If

Application.Cursor = xlWait

'Trouve le lecteur de la clé.

LecteurDestination = RemovableDisk(LecteurSource)

If LecteurDestination<> "" Then

   'Teste si le lecteur est prêt...

   Prêt = EstPret(LecteurDestination)

   If Prêt = False Then

   MsgBox "Le lecteur amovible n'est pas prêt."

   Exit Sub

   End If

Else

   MsgBox "Aucun disque amovible détecté."

   Exit Sub

End If

'Création du répertoire si nécessaire sur la clé

'si le répertoire est déjà présent, rien n'est modifié.

Creer_Chemin LecteurDestination, Chemin

DoEvents

'Copier en utiliser les API de Windows du répertoire source

'vers le répertoire de destination

If CopieDossier(Répertoire, LecteurDestination& Chemin, FO_COPY, True) Then

   MsgBox "Opération réussie"

Else

   MsgBox "Un problème fut rencontré."

End If

Application.Cursor = xlDefault

End Sub

'-------------------------------------

Function RemovableDisk(MonLecteur As String)

strComputer = "."

Set objWMIService = GetObject("winmgmts:" _

   & "{impersonationLevel=impersonate}!\"& _

   strComputer& "\root\cimv2")

Set colDisks = objWMIService.ExecQuery _

   ("Select * from Win32_LogicalDisk")

For Each Objdisk In colDisks

   '2 constante numérique pour disque dur "removable"

   If Objdisk.DriveType = 2 Then

   RemovableDisk = Objdisk.Name& ""

   Exit Function

   End If

Next

End Function

'-------------------------------------

Function EstPret(Lecteur As String)

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set colDrives = objFSO.Drives

For Each objdrive In colDrives

   If Lecteur = objdrive& "" Then

   If objdrive.IsReady = True Then

   EstPret = objdrive.IsReady

   End If

   End If

Next

End Function

'-------------------------------------

Sub Creer_Chemin(Racine, Chemin As String)

Dim Commande As String

'Crée le chemin indiqué si les répertoires ne

'sont pas présents. N'écrase rien !

ChDrive Racine

Commande = Environ("comspec")& " /c mkdir "& Chemin

Shell Commande, 0

End Sub

'-------------------------------------

Private Function CopieDossier(Source As String, Dest As String, _

Optional Action As Byte, Optional Animation As Boolean) As Boolean

   Dim OpStruct As SHFILEOPSTRUCT

   With OpStruct

   .wFunc = Action

   .pFrom = Source

   .pTo = Dest

   'POUR MESSAGE AVANT D'ÉCRASER : 4 AU LIEU DE 10

   .fFlags = 4

   End With

   CopieDossier = IIf(SHFileOperationA(OpStruct), False, True)

End Function

'-------------------------------------

J@@
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire
Anonyme

2010-07-12T05:45:13+00:00

| Sous XL2000 et Win XP

| Désolé, seuls les répertoires et ssrépertoires sont créés sur ma machine

Si tel est le cas, c'est étrange, je n'éprouve aucune difficulté sous Windows7 et Excel 2007

Je te remercie pour les tests que tu as effectués.

Si tu préfères l'usage des API de Windows....

La copie est quand même assez longue compte tenu que

la copie s'effectue vers un clé... Tu peux remplacer tout le

code du module du classeur exemple avec ceci :

'Déclaration des API dans le haut d'un module Standard

Type SHFILEOPSTRUCT

hwnd As Long

wFunc As Long

pFrom As String

pTo As String

fFlags As Integer

fAnyOperationsAborted As Boolean

hNameMappings As Long

lpszProgressTitle As String

End Type

Const FO_MOVE = 1

Const FO_COPY = 2

Const FO_DELETE = 3

Const FO_RENAME = 4

Const FOF_SILENT = 4

Const FOF_NOCONFIRMATION = 10

Private Declare Function SHFileOperationA Lib "Shell32.dll" _

(lpFileOp As SHFILEOPSTRUCT) As Long

'-------------------------------------

Sub Test()

Dim LecteurSource As String, Prêt As Boolean

Dim LecteurDestination As String

Dim Chemin As String

Dim Répertoire As String

'Le répertoire où se retrouve le fichier

Répertoire = ThisWorkbook.Path & ""

'Si on désire effectuer la copie vers la clé vers un

'répertoire d'appellation différente que le répertoire sourcee :

'*************** À RENSEIGNER******************

Chemin = "toto\tutu\titi" ' à renseigner

'***********************************************

LecteurSource = Left(Répertoire, 3)

If Chemin = "" Then

Chemin = Right(Répertoire, Len(Répertoire) - 3)

End If

Application.Cursor = xlWait

'Trouve le lecteur de la clé.

LecteurDestination = RemovableDisk(LecteurSource)

If LecteurDestination <> "" Then

'Teste si le lecteur est prêt...

Prêt = EstPret(LecteurDestination)

If Prêt = False Then

MsgBox "Le lecteur amovible n'est pas prêt."

Exit Sub

End If

Else

MsgBox "Aucun disque amovible détecté."

Exit Sub

End If

'Création du répertoire si nécessaire sur la clé

'si le répertoire est déjà présent, rien n'est modifié.

Creer_Chemin LecteurDestination, Chemin

DoEvents

'Copier en utiliser les API de Windows du répertoire source

'vers le répertoire de destination

If CopieDossier(Répertoire, LecteurDestination & Chemin, FO_COPY, True) Then

MsgBox "Opération réussie"

Else

MsgBox "Un problème fut rencontré."

End If

Application.Cursor = xlDefault

End Sub

'-------------------------------------

Function RemovableDisk(MonLecteur As String)

strComputer = "."

Set objWMIService = GetObject("winmgmts:" _

& "{impersonationLevel=impersonate}!\" & _

strComputer & "\root\cimv2")

Set colDisks = objWMIService.ExecQuery _

("Select * from Win32_LogicalDisk")

For Each Objdisk In colDisks

'2 constante numérique pour disque dur "removable"

If Objdisk.DriveType = 2 Then

RemovableDisk = Objdisk.Name & ""

Exit Function

End If

Next

End Function

'-------------------------------------

Function EstPret(Lecteur As String)

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set colDrives = objFSO.Drives

For Each objdrive In colDrives

If Lecteur = objdrive & "" Then

If objdrive.IsReady = True Then

EstPret = objdrive.IsReady

End If

End If

Next

End Function

'-------------------------------------

Sub Creer_Chemin(Racine, Chemin As String)

Dim Commande As String

'Crée le chemin indiqué si les répertoires ne

'sont pas présents. N'écrase rien !

ChDrive Racine

Commande = Environ("comspec") & " /c mkdir " & Chemin

Shell Commande, 0

End Sub

'-------------------------------------

Private Function CopieDossier(Source As String, Dest As String, _

Optional Action As Byte, Optional Animation As Boolean) As Boolean

Dim OpStruct As SHFILEOPSTRUCT

With OpStruct

.wFunc = Action

.pFrom = Source

.pTo = Dest

'POUR MESSAGE AVANT D'ÉCRASER : 4 AU LIEU DE 10

.fFlags = 4

End With

CopieDossier = IIf(SHFileOperationA(OpStruct), False, True)

End Function

'-------------------------------------

MichD
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire
Anonyme

2010-07-12T05:19:40+00:00

Bonjour Denis

Désolé, seuls les répertoires et ssrépertoires sont créés sur ma machine. Très rapidement d'ailleurs.

Sinon, le test d'existence de clé est OK.

Ma remarque sur xcopy était erronée, tu l'avais bien corrigée.

Je répondais juste à ta demande de testeur. Je n'ai pas l'usage de ce code.

@+

J@@

Le 11/07/2010 17:21, MichD [MVP] a écrit :

| Sous XL2000 et Win XP, les répertoires sont bien

| créés sur la clé USB, mais les fichiers ne sont pas copiés. Pb de Xcopy?

Je suis en total désaccord avec cette énoncé.

Comme la commande utilisée est une ancienne commande "DOS", elle beaucoup moins

rapide que l'utilisation des API. Je viens de la testée tel qu'elle est écrite dans le fichier.

Le répertoire contenant ce fichier contenait 20 autres fichiers et 2 sous-répertoires avec

20 fichiers chacun. Tout a été copié correctement.

Afin de noter la progression de la macro, je t'invite à modifier légèrement la macro "Test" du module comme ceci :

'------------------------

Sub Test()

Application.Cursor = xlWait

Copie_répertoire_Source ThisWorkbook.Path, "Toto\titi\tutu"

Application.Cursor = xlDefault

End Sub

'------------------------

L'état du curseur t'indiquera le moment où la macro se terminera.

Si le demandeur a plusieurs fichiers à copier, je crois qu'il serait possible de faire cela avec les API de Windows... mais pour cela ça attendra demain.

J@@
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire
Anonyme

2010-07-12T03:21:31+00:00

| Sous XL2000 et Win XP, les répertoires sont bien

| créés sur la clé USB, mais les fichiers ne sont pas copiés. Pb de Xcopy?

Je suis en total désaccord avec cette énoncé.

Comme la commande utilisée est une ancienne commande "DOS", elle beaucoup moins

rapide que l'utilisation des API. Je viens de la testée tel qu'elle est écrite dans le fichier.

Le répertoire contenant ce fichier contenait 20 autres fichiers et 2 sous-répertoires avec

20 fichiers chacun. Tout a été copié correctement.

Afin de noter la progression de la macro, je t'invite à modifier légèrement la macro "Test" du module comme ceci :

'------------------------

Sub Test()

Application.Cursor = xlWait

Copie_répertoire_Source ThisWorkbook.Path, "Toto\titi\tutu"

Application.Cursor = xlDefault

End Sub

'------------------------

L'état du curseur t'indiquera le moment où la macro se terminera.

Si le demandeur a plusieurs fichiers à copier, je crois qu'il serait possible de faire cela avec les API de Windows... mais pour cela ça attendra demain.

| Pour xcopy :/S et /E me semblent non compatibles

Justement, cela permet de reproduire exactement tout ce dont le répertoire et sous-répertoire contiennent avec fichiers ou sans fichier. C'est le but d'une sauvegarde... NON ?

MichD

"Jipirouge987" a écrit dans le message de groupe de discussion : *** Adresse électronique supprimée pour cause de confidentialité ***...

Bonjour Denis

Sous XL2000 et Win XP, les répertoires sont bien créés sur la clé USB, mais les fichiers ne sont pas copiés. Pb de Xcopy?

Pour xcopy :/S et /E me semblent non compatibles

* à l'exception des rép vides

* y compris les rép vides

@+

J@@

Le 11/07/2010 08:22, MichD [MVP] a écrit :

Dans le fichier que je t'ai envoyé, tu devais simplement le copier

dans un répertoire de ton ordi...!

Si tu enlèves cette section du code, la copie des fichiers se fait-elle correctement ?

Je ne sais pas pourquoi tu obtiens ce message...

En fait, je n'ai jamais eu l'occasion de tester ce code dans un environnement

autre que le mien.

Peut-être que d'autres usagers de ce groupe de discussion testeront le fichier

et nous dirons le résultat de leur expérience.

-- J@@
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire