comment ouvrir un dossier avec VBA Résolu

Question

Bonjour, 

je suis à la recherche d'une macro qui ouvre un dossier dont le nom est dans une liste excel
exemple dans une liste récapitulative j'ai E1234 
dans un dossier sur trouve plusieurs dossier, est seul est nommé E1234, blabla
lorsque la cellule de ma liste qui contient E1234 je veux cliquer sur un bouton pour ouvrir le fameux dossier du même nom.

merci beaucoup 

<config>Windows xp /office 2003

Bidouilleu_R · Answer

Bonjour,
ce que tu souhaites faire n'est pas clair ou incomplet.

On ne peut pas ouvrir un dossier ( au sens d'ouvrir comme un fichier), 
Dans l'explorateur windows quand tu vois le dossier "ouvert" cela signifie que tu te positionnes à cet emplacement.
en vba on utilise CHDIR (LeCheminComplet)

Dans ton cas on pourrait avoir un dossier de travail C:\Travail\ dans lequel il y a ton classeur Excel et quand tu récupères "E1234"
tu pourrais avoir quelque chose comme ça...


Dim maVariable As String

maVariable="E1234"  ' là je lui mets directement la valeur

Chdir (ThisWorbook.path & "\" & maVariable)

Bidouilleu_R · Answer

j'ai compris ce que tu veux faire

Comme ça!

Sub test()

 ShellExecute 0, "explore", "G:\Docu\R&D\Rapports d'essais", "", "", 10


End Sub

Bidouilleu_R · Answer

là je ne comprends plus ce que tu ne comprends pas ....
dans 
ShellExecute 0, "explore", "G:\Docu\R&D\Rapports d'essais", "", "", 10 

et hop sa ouvrais mon dossier Alsacien?

"Je voudrai qui l'en soit de même pour m'afficher le contenu du dossier qui commence par ce même nom (E 1234, dossier blabla) "
Je ne sais pas ce qu'il y as dans le dossier spécifié...
si tu me dis ... dans le dossier\...\ E1234\    j'ai des pdf qui s'appelle E1234.htm, 1234essai.pdf, 1234 rapport.doc, 1234truc.asp,
Je vois que tu es dans ton univers tu sais de quoi tu parles mais j'ai du mal à te suivre. 
Explique mieux s'il te plait

Supercopain · Answer

c'est exactement ça je suis dans mon truc et pour l'expliquer...

Alors en 1er j'ouvre mon tableau excel appelé "Gestion des essais.xls" dans lequel il y a une colonne qui répertorie tout les numéros d'essais (E1234.....) 
et de ce numéro (1 par essai) 
en 2éme je souhaite ouvrir le dossier qui porte CE numéro E1234.. (qui se trouve dans le répertoire G/docu/retd/essais terminés)
 
la macro qui est plus haut je l'utilise pour ouvrir uniquement les PDF (ordre d'essai et les rapports d'essai) qui se trouvent dans les dossiers "Ordres d'essais" et "Rapport d'essai"

voila je vais vous laisser tranquille, 

MERCI POUR VOTRE AIDE

Bidouilleu_R · Answer

je te propose de faire comme ça

sur la feuille qui contient les valeurs d'essai ( un essai = un repertoire)
click de droit sur l'onglet et choisi : code

tu colles ce code .....



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


dans un module tu devras mettre la fonction
comme ceci, si elle existe déjà inutile de la remettre.


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

Explication :Quand tu click sur une cellule de ta liste d'essai cela déclenche la macro
si la cellule est vide tu ne fais rien sinon tu ouvres le répertoire avec l'explorateur.

supercopain · Answer

Hello,
J'ai testé ça fonctionne, 
mais (hé oui il y un mais..) 
1-je veux que la macro soit activée par un bouton appelé : [OUVRIR LE DOSSIER]
   
et en plus, il faut tenir compte uniquement des 6 premiers caractéres (nom du dossier par exemple:  E 1234, blabla)

Un grand merci pour votre précieuse aide.

Bidouilleu_R · Answer

Bonjour,  

Excuse-moi j'avais oublié ce détail,  

Dans un module   
copie et colle le code ci-dessous.  

Ajoute un bouton sur ta feuille, affecte-lui la macro et test  

Attention il faut enlever le code précédent que tu as placé dans la feuille, 
sinon il y aura un problème.


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

Bidouilleu_R · Answer

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

Bidouilleu_R · Answer

j'ai fais le test pas de pb chez moi.

il faut que tu adaptes au besoin la variable chainePath 
A+


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

Bidouilleu_R · Answer

Essaye ce code!  
et supprime le précédent tu devrais gagner en vitesse.  
je n'ai pas mis le message '...en cours de recherche...'  
Tu test et  tu dis.  


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

Bidouilleu_R · Answer

J'ai rajouté un message
Pense à mettre en résolu si c'est ok!

le message apparaîtra en bas à gauche de la feuille,
tous les 20 dossiers.
A l'endroit où tu vois 'Prêt'








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


V = ""
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)
    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)
'
Dim j As Integer
Dim msgStatusBarre As String

msgStatusBarre = Application.DisplayStatusBar ' sauvegarde

    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 20) = 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

supercopain · Answer

Hello,
Tout fonctionne avec affichage dans la barre en bas ... mais, je souhaiterai (je sais, je suis pénible..) 
un message ou une indication de chargement qui ferait patienter l'utilisateur (ce n'est pas toujours moi qui l'utilise)

Merci.

Bidouilleu_R · Answer

Modifie seulement la macro afficheListeDossier
l'utilisateur devra valider le message!

c'est toi qui choisit



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

supercopain · Answer

Ok ça marche! Super!!
Je vais tester pendant quelques temps cette nouvelle version de mon fichier.
J'ai fini de t'ennuyer avec mes questions,... enfin pour le moment...
heuu, encore une petite question comment je fais pour "mettre en résolu"

Merci beaucoup et bon week-end!

Comment ouvrir un dossier avec VBA

14 réponses

Discussions similaires

Newsletters