Enregistrement sur clé USB

[mavean]

Bonjour à tous et joyeux NOEL

j'utilise dans une macro le code suivant :

semaine = InputBox("Numéro de semaine ?")
ChDir "C:\RESTOS"
ActiveWorkbook.SaveAs Filename:= _
"C:\RESTOS\FICHIER POUR RENTRER LES STOCKS S" & semaine & ".xls", FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False

Macro qui marche normalement, sauf que j'enregistre sur C:\ parce que je ne sais pas le faire sur une clé USB.
En effet j'utilise ce fichier sur 3 PC et la lettre de la Clé n'est jamais la même !!!
Existe t'il un code qui m'enregistre le fichier sur ma clé USB (dans le dossier RESTOS ) quel que soit le PC.
Qui peut me réécrire le code.

Merci et joyeux NOEL

 

[JBARBE]

Re : Enregistrement sur clé USB

Bonsoir à tous,

Il est indéniable que la racine C du disque dur ici présente dans l'écriture de la macro( si celle-ci fonctionne ), doit être remplacée par la racine de la clé USB !

Ce serait facile si cette racine été toujours la même "exemple" " D " mais comme tu le dit pour plusieurs PC ce ne sera pas toujours le cas !

De ce fait, sans l'obtention de cette racine et, de plus, différente ( je pense ), il est difficile d'obtenir la bonne solution !

Désolé ( pour moi ) !

bonne soirée & Joyeux Noël !

 

[mapomme]

Re : Enregistrement sur clé USB

Joyeux Noël à mavean, à JBARBE et à toutes et tous ,

Il est dommage qu'aucun fichier n'ait été fourni avec la question !

Mais comme le problème risque un jour de se présenter à moi, je m'y suis intéressé.

Un essai d'une fonction VBA : VolumeUSB(Chemin)

• dont le paramètre d'entrée est le chemin (à partir de la racine) d'un dossier à chercher sur un volume amovible (ex: "C:\RESTOS")
• qui retourne la lettre du premier périphérique amovible rencontré comprenant le dossier \RESTOS à sa racine
• ou bien retourne la chaine de caractère vide si aucun lecteur amovible ne contient \RESTOS à sa racine

Si VolumeUSB(Chemin) retourne une lettre, il est ensuite facile de remplacer c: par VolumeUSB(Chemin) &":" (en supposant qu'il n'y a qu'un seul lecteur amovible qui satisfasse la condition )


Le code de la fonction :

Function VolumeUSB$(Chemin$)
Dim FSO, Volume, LettreVolume$
  Set FSO = CreateObject("Scripting.FileSystemObject")
  For Each Volume In FSO.Drives
    If Volume.drivetype = 1 Then
      If FSO.FolderExists(Volume.driveletter & Mid(CheminStockage, 2)) Then
        VolumeUSB = Volume.driveletter
        Exit Function
      End If
    End If
  Next Volume
End Function

 

[Tentative]

Re : Enregistrement sur clé USB

Joyeux temps des Fêtes MaPomme!

Sur ma machine, j'ai le message : " Désolé ... Nous ne trouvons pas .......XLSTART\mapomme.xlam. Peut-être l'avez-vous déplacé, renommé ou supprimé?

Édit : Si j'exécute la macro manuellement, ça fonctionne ... désolé du dérangement.

Édit 2 : La macro ne trouve pas si c'est une autre unité de disque dur 8- //

Euh! Merci pour le code


Tentative

 

[mapomme]

Re : Enregistrement sur clé USB

Bonsoir Tentative

(...) Sur ma machine, j'ai le message : " Désolé ... Nous ne trouvons pas .......XLSTART\mapomme.xlam. Peut-être l'avez-vous déplacé, renommé ou supprimé? (...)

Essayer avec le fichier v1a dans mon premier message ici.

(...) La macro ne trouve pas si c'est une autre unité de disque dur (...)

Si c'est un disque dur interne, c'est normal -> je les exclus de ma recherche. Si c'est un disque dur externe, je n'en ai pas sous la main pour l'instant donc je ne peux pas tester.

 

[MJ13]

Re : Enregistrement sur clé USB

Bonjour à tous

Sinon, on peut changer la lettre d'une clé USB pour que ce soit toujours le même nom, quelque soit l'ordinateur. Exemple, vous pouvez l'appeler A.

Pour cela, click droit dans l'explorateur sur l'ordinateur, choisir gérer et Stockage (de mémoire).

 

[david84]

Re : Enregistrement sur clé USB

Bonjour à tous,

Si c'est un disque dur externe, je n'en ai pas sous la main pour l'instant donc je ne peux pas tester.

Si c'est un disque dur externe il ramène les mêmes informations qu'un disque dur interne : Volume.drivetype=2
A+

 

[Marc L]

Bonjour,

démonstration pour trouver le disque nommé "USB" :

​

Function FindVolume$(VOL$)
    Dim oDisks As Object, oDisk As Object
    Set oDisks = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * from Win32_LogicalDisk where VolumeName = '" & VOL & "'")
    For Each oDisk In oDisks:  FindVolume = oDisk.DeviceID:  Next
    Set oDisks = Nothing
End Function


Sub Demo()
    MsgBox FindVolume("USB")
End Sub

_______________________________________________________________________________
Merci de cliquer sur J'aime ce post en bas à gauche de chaque message ayant aidé …

_______________________________________________________________________________
Je suis Paris, …
​

 

[mapomme]

Re : Enregistrement sur clé USB

Bonjour à tous,

Comme il peut avoir plusieurs unités qui répondent à la condition,
pour le fun: un essai qui, pour la sélection de l'unité, liste l'ensemble des lecteurs (amovibles ou pas) qui contiennent un dossier prédéfini à leur racine. (si on le désire, on peut aussi lister tous les volumes en prenant "." comme dossier prédéfini)

 

[MJ13]

Re : Enregistrement sur clé USB

Re

Sinon, sur une appli, j'utilise ce code pour lister tous les lecteurs disponibles.

Code VBA:
Sub recherche_lecteurs_SurFeuille()
'code adapté par MJ issu de https://www.excel-downloads.com/threads/trouver-un-fichier-sur-le-pc.14470/
Derl = Range("K65536").End(xlUp).Rows.Row
Range("K2:L" & Derl).Select
Selection.ClearContents
Dim Fso As Object
Dim Drv As Object
Dim Msg$
Range("K2").Select
Set Fso = CreateObject("Scripting.FileSystemObject")
Msg = "Votre système a " & Fso.drives.Count & " lecteurs :" & vbLf & vbLf
For Each Drv In Fso.drives
With Drv
'Stop
Select Case .DriveType
Case 0 ' unknown
Msg = Msg & "Lecteur: " & .DriveLetter & " est de type inconnu." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "type inconnu"
ActiveCell.Offset(1, -1).Range("A1").Select
Case 1 ' removable, e.g., zip
Msg = Msg & "Lecteur: " & .DriveLetter & " est un disque amovible." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "disque amovible"
ActiveCell.Offset(1, -1).Range("A1").Select
Case 2 ' fixed, hard drive
Msg = Msg & "Lecteur: " & .DriveLetter & " est un disque dur." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "disque dur"
ActiveCell.Offset(1, -1).Range("A1").Select
Case 3 ' remote
Msg = Msg & "Lecteur: " & .DriveLetter & " est un disque réseau." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "disque réseau"
ActiveCell.Offset(1, -1).Range("A1").Select
Case 4 ' CDROM
Msg = Msg & "Lecteur: " & .DriveLetter & " est un CDROM." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "CDROM"
ActiveCell.Offset(1, -1).Range("A1").Select
Case 5 ' ram disk
Msg = Msg & "Lecteur: " & .DriveLetter & " est un disque virtuel." & vbLf
ActiveCell.Value = .DriveLetter & ":\"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.Value = "disque virtuel"
ActiveCell.Offset(1, -1).Range("A1").Select
End Select
End With
Next Drv
Cells(2, 1).Select
'MsgBox Msg, , "Lecteurs du système"
End Sub

Sub Trouve_CléUSB()
Dim Fso As Object
Dim Drv As Object
Dim Msg$
Set Fso = CreateObject("Scripting.FileSystemObject")
'MsgBox ("Votre système a " & FSO.drives.Count & " lecteurs :" & vbLf & vbLf)
For Each Drv In Fso.drives
If Drv.DriveType = 1 Then MsgBox (Drv & " est un Disque amovible")
Next

End Sub

 

[Marc L]

Visualisation :

​

 

[MJ13]

Re : Enregistrement sur clé USB

Re

@Marc_L: Il me semble, qu'on doit pouvoir aussi trouver le numéro de série d'un lecteur?

Si tu as le code, ça m'intéresse .

 

[Marc L]

Ton code utilisant FileSystemObject, il y a la propriété [highlight]SerialNumber[/code] …

​

 

[MJ13]

Re : Enregistrement sur clé USB

Re

Ok, merci.Cela donnerait donc ceci :

Sub Trouve_CléUSB()
Dim Fso As Object
Dim Drv As Object
Dim Msg$
Set Fso = CreateObject("Scripting.FileSystemObject")
'MsgBox ("Votre système a " & FSO.drives.Count & " lecteurs :" & vbLf & vbLf)
For Each Drv In Fso.drives
If Drv.DriveType = 1 Then MsgBox (Drv & " est un Disque amovible")
If Drv.DriveType = 1 Then MsgBox (Drv.SerialNumber)
Next
End Sub

 

[Marc L]

Recherche disque par n° de série :

on doit pouvoir aussi trouver le numéro de série d'un lecteur?.

Visualisation :

​

Function FindDiskSerial$(DEV$)
    Dim oDisks As Object, oDisk As Object
    Set oDisks = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * from Win32_LogicalDisk where DeviceID = '" & DEV & "'")
    For Each oDisk In oDisks:  FindDiskSerial = oDisk.VolumeSerialNumber:  Next
    Set oDisks = Nothing
End Function


Function FindSerialVolume$(NUM$)
    Dim oDisks As Object, oDisk As Object
    Set oDisks = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * from Win32_LogicalDisk where VolumeSerialNumber = '" & NUM & "'")
    For Each oDisk In oDisks:  FindSerialVolume = oDisk.DeviceID:  Next
    Set oDisks = Nothing
End Function


Sub DemoFindDiskSerial()
    Debug.Print FindDiskSerial("K:")
End Sub


Sub DemoFindSerialVolume()
    Debug.Print FindSerialVolume("1")
End Sub

_______________________________________________________________________________
Merci de cliquer sur J'aime ce post en bas à gauche de chaque message ayant aidé …
​