Sub test()
Dim Chemin As String, T As String, S As Variant
Dim LecteurSource As String, A As Integer, Ok As Boolean
'***********Variable à renseigner*********
Chemin = "Outils\Dossier A\"
'*******************************************
T = RemovableDisk(LecteurSource)
If InStr(1, T, ",", vbTextCompare) > 0 Then
S = Split(T, ",")
Else
If Dir(T & Chemin, vbDirectory) <> "" Then
ChDrive Left(T, 1)
ChDir T & Chemin
Ok = True
MsgBox "Répertoire courant : " & T & Chemin
Exit Sub
Else
MsgBox "Chemin """ & T & Chemin & _
""" inexistant sur cette clé : " & T
Exit Sub
End If
End If
For A = LBound(S) To UBound(S)
If Dir(S(A) & Chemin, vbDirectory) Then
Application.DefaultFilePath = Dir(S(A) & Chemin)
MsgBox "Répertoire courant : " & T & Chemin
Ok = True
Exit Sub
End If
Next
If Ok = False Then
MsgBox "Chemin """ & T & Chemin & _
""" inexistant sur cette clé : " & T
End If
End Sub
'-------------------------------------------------------
Function RemovableDisk(MonLecteur As String)
Dim strComputer As String, objWMIService As Object
Dim Objdisk As Object, colDisks As Object
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 = RemovableDisk & Objdisk.Name & "\" & ","
End If
Next
If RemovableDisk <> "" Then
RemovableDisk = Left(RemovableDisk, Len(RemovableDisk) - 1)
End If
End Function
Private Declare Function GetVolumeInformation Lib "Kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Function GetVolumeName(ByVal cDrive As String) As String
' http://www.codyx.org/snippet_recuperer-nom-attribue-lecteur-disque-cle-etc_863.aspx
' cDrive = CHAR (lettre) de A à Z
Dim sBuffer As String
Dim iEnd As Integer
sBuffer = Space$(255)
GetVolumeInformation cDrive & ":\", sBuffer, Len(sBuffer), 0&, 0&, 0&, vbNullString, 0&
iEnd = InStr(1, sBuffer, vbNullChar)
If iEnd Then GetVolumeName = Left$(sBuffer, iEnd - 1)
End Function
Function lettreLecteur(nomLecteur As String) As String
Dim l As Long
For l = 1 To 26
If GetVolumeName(Chr(64 + l)) = nomLecteur Then
lettreLecteur = Chr(l + 64)
Exit For
End If
Next l
End Function
Sub test()
Dim r As String, nomLecteur As String
nomLecteur = "KINGSTON"
r = lettreLecteur(nomLecteur)
If r <> "" Then
MsgBox ("Lettre du lecteur '" & nomLecteur & "' = " & r)
Else
MsgBox ("Lecteur '" & nomLecteur & "' non trouvé.")
End If
End Sub
comment puis-je ouvrir "Outils\Dossier A" avec la bonne lettre identifiée ?
If Objdisk.DriveType = 2 Then
RemovableDisk = RemovableDisk & Objdisk.Name & "\" & ","
End If
If Objdisk.DriveType = 2 And Objdisk.FreeSpace > 0 Then
RemovableDisk = RemovableDisk & Objdisk.Name & "\" & ","
End If