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-13T12:25:22+00:00

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
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire
Anonyme

2010-07-13T09:22:59+00:00

Merci pour ce retour.

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

0 commentaires Aucun commentaire
Anonyme

2010-07-13T04:01:05+00:00

Bonjour Denis

Voilà, cela marche.

C'est de ma faute, je n'avais pas défini ce qu'il fallait copier : j'ai ajouté**.** à Repertoire :

'******

'Le répertoire où se retrouve le fichier

Répertoire = ThisWorkbook.Path & "\*.*" '<= ici

'******

et tout se copie parfaitement sur la clé usb.

Tout va bien.

@+

cordialement

J@@

Le 12/07/2010 09:34, MichD [MVP] a écrit :

C'est particulier... En théorie et en pratique, il n'y a rien dans ces procédures

que Windows Xp ne saurait réaliser. Que tu éprouves des problèmes avec

les 2 solutions proposées c'est surprenant.

As-tu vérifié si tu as les "droits" requis pour pouvoir copier ces fichiers ?

Si oui, une dernière tentative...

Dans la procédure "Test" d'hier (celle avec API), remplace la ligne de commande

DoEvents par ceci

Tu déclares la variable T as double

Dim T as Double

t = Timer + 2

Do While Timer<= t

DoEvents

Loop

Au-delà de cette suggestion, je n'ai plus d'idées !

Je ne vais pas installer à nouveau Windows Xp pour cela ! ;-))

Merci pour les tests que tu as effectués.

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

0 commentaires Aucun commentaire
Anonyme

2010-07-12T19:34:44+00:00

C'est particulier... En théorie et en pratique, il n'y a rien dans ces procédures

que Windows Xp ne saurait réaliser. Que tu éprouves des problèmes avec

les 2 solutions proposées c'est surprenant.

As-tu vérifié si tu as les "droits" requis pour pouvoir copier ces fichiers ?

Si oui, une dernière tentative...

Dans la procédure "Test" d'hier (celle avec API), remplace la ligne de commande

DoEvents par ceci

Tu déclares la variable T as double

Dim T as Double

t = Timer + 2

Do While Timer <= t

DoEvents

Loop

Au-delà de cette suggestion, je n'ai plus d'idées !

Je ne vais pas installer à nouveau Windows Xp pour cela ! ;-))

Merci pour les tests que tu as effectués.

MichD

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

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