How to open a folder with VBA

Public Sub AfficherListeDossiers(ByVal specdossier As String, ByRef Fso, ByVal leChemin) Dim j As Integer Dim msgStatusBarre As String Dim s As Variant msgStatusBarre = Application.DisplayStatusBar ' sauvegarde s = MsgBox("Recherche du dossier contenant ... " & leChemin, vbInformation, "Information recherche") Dim dossier, fd, sDossier ' variable de type variant ' Set Fso = CreateObject("Scripting.FileSystemObject") ' créé un objet fileSystem Set dossier = Fso.GetFolder(specdossier) ' dossier : héritage de fso Set sDossier = dossier.SubFolders 'sDossier : héritage de dossier j = 0 For Each fd In sDossier ' Scanne la collection sDossier j = j + 1 If (j Mod 2) = 0 Then ' mise à jour du message tous les 20 dossiers Application.StatusBar = j & " traités sur : " & sDossier.Count End If If InStr(1, fd.Name, V) > 0 Then V = fd Exit For End If Next Set sDossier = Nothing Set dossier = Nothing Application.StatusBar = False Application.DisplayStatusBar = msgStatusBarre End Sub

Option Explicit Sub Worksheet_SelectionChange(ByVal Target As Range) Dim C, V If Not Intersect(Target, Range("A2:A80")) Is Nothing Then ' the range that contains the tests Application.ScreenUpdating = False V = ActiveCell.Value If V <> "" Then ShellExecute 0, "explore", "G:\Docu\R&D\Rapports d'essais" & V, "", "", 10 ' ShellExecute 0, "explore", "C:\Data\" & V, "", "", 10 End If End If End Sub

 Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Option Explicit Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Sub OpenFolder() Dim Target As Range Dim C, V Set Target = ActiveCell If Not Intersect(Target, Range("A2:A80")) Is Nothing Then ' the range containing the trials Application.ScreenUpdating = False V = Left(ActiveCell.Value, 6) ' we take only 6 characters If V <> "" Then ShellExecute 0, "explore", "G:\Docu\R&D\Rapports d'essais" & V, "", "", 10 ' ShellExecute 0, "explore", "C:\Data\" & V, "", "", 10 End If End If End Sub

Option Explicit Public idxTablo As Integer Public TabloDossier() As String Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Sub OpenFolder() Dim Target As Range Dim C, V Dim i As Integer Dim chainePath As String Set Target = ActiveCell chainePath="G:\Docu\R&D\Rapports d'essais" 'chainePath = "C:\Data\2009" If Not Intersect(Target, Range("A2:A20")) Is Nothing Then ' the range that contains the tests Application.ScreenUpdating = False V = Left(Replace(ActiveCell.Value, "E", "E ", 1), 6) idxTablo = 0 ReDim Preserve TabloDossier(idxTablo) TabloDossier(idxTablo) = chainePath idxTablo = 1 Call AfficherListeDossiers(chainePath, CreateObject("scripting.filesystemobject")) For i = 0 To UBound(TabloDossier) If InStr(1, TabloDossier(i), V) > 0 Then V = TabloDossier(i) Exit For End If Next If V <> "" Then 'ShellExecute 0, "explore", V, "", "", 10 ShellExecute 0, "explore", V, "", "", 10 End If End If End Sub Public Sub AfficherListeDossiers(ByVal specdossier As String, ByRef Fso) Dim dossier, fd, sDossier ' variable de type variant ' Set Fso = CreateObject("Scripting.FileSystemObject") ' create a FileSystem object Set dossier = Fso.GetFolder(specdossier) ' dossier : FSO heirarchy Set sDossier = dossier.SubFolders 'sDossier : heirarchy of folder ReDim Preserve TabloDossier(idxTablo) ' global variable For Each fd In sDossier ' Scan the sDossier collection ReDim Preserve TabloDossier(idxTablo) TabloDossier(idxTablo) = fd.Path idxTablo = idxTablo + 1 Next Set sDossier = Nothing Set dossier = Nothing If TabloDossier(UBound(TabloDossier)) = "" Then ReDim Preserve TabloDossier(UBound(TabloDossier) - 1) End If End Sub

Option Explicit Public V As String Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Sub OuvreDossier() Dim Target As Range Dim i As Integer V = "" Dim chainePath As String Set Target = ActiveCell chainePath = "G:\Docu\R&D\Rapports d'essais" 'chainePath = "C:\Data" If Not Intersect(Target, Range("A2:A20")) Is Nothing Then ' la plage qui contient les essais Application.ScreenUpdating = False V = Left(Replace(ActiveCell.Value, "E", "E ", 1), 6) Call AfficherListeDossiers(chainePath, CreateObject("scripting.filesystemobject"), V) If V <> "" Then ShellExecute 0, "explore", V, "", "", 10 End If End If End Sub Public Sub AfficherListeDossiers(ByVal specdossier As String, ByRef Fso, ByVal leChemin) ' ' il faut déclarer i en global ' Dim dossier, fd, sDossier ' variable de type variant ' Set Fso = CreateObject("Scripting.FileSystemObject") ' créé un objet fileSystem Set dossier = Fso.GetFolder(specdossier) ' dossier : héritage de fso Set sDossier = dossier.SubFolders 'sDossier : héritage de dossier For Each fd In sDossier ' Scanne la collection sDossier If InStr(1, fd.Name, V) > 0 Then V = fd Exit For End If Next Set sDossier = Nothing Set dossier = Nothing End Sub