Comment ouvrir un dossier avec 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  ' la plage qui contient les essais
    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 OuvreDossier()  

Dim Target As Range  

Dim C, V  

Set Target = ActiveCell  


If Not Intersect(Target, Range("A2:A80")) Is Nothing Then  ' la plage qui contient les essais  
    Application.ScreenUpdating = False  
    V = Left(ActiveCell.Value, 6)     ' on ne prend que 6 charatères  
    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   

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 C, V   

Set Target = ActiveCell   


If Not Intersect(Target, Range("A2:A80")) Is Nothing Then  ' la plage qui contient les essais   
    Application.ScreenUpdating = False   
    v = Left(Replace(ActiveCell.Value, "E", "E ", 1), 6)  ' remplace "E1234,blabla" par "E 1234"  
    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 OuvreDossier()

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  ' la plage qui contient les essais
    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") ' créé un objet fileSystem
    Set dossier = Fso.GetFolder(specdossier)             ' dossier : héritage de fso
    Set sDossier = dossier.SubFolders                    'sDossier : héritage de dossier
                                   
    ReDim Preserve TabloDossier(idxTablo)          ' variable globale
  
   
    For Each fd In sDossier                 ' Scanne la collection sDossier
        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