VBA Excel procédure créant un menu déroulant listant des fichiers à ouvrir

Question

Bonjour, je souhaite insérer une procédure VBA dans une feuille Excel qui ouvre un menu déroulant permettant d’ouvrir un fichier parmi ceux figurant sur mon disque dur :

Le menu déroulant propose 3 choix :

· « Fichiers .doc » · « Fichiers .pdf » · « Fichiers .xls »

L'utilisateur clique sur un de ces choix : un sous-menu déroulant s’ouvre affichant la liste des fichiers (.doc, ou .pdf ou .xls selon le choix cliqué) présents dans un répertoire désigné par son chemin sur le disque dur (ce répertoire est composé éventuellement de plusieurs répertoires).

Dans l’idéal, seuls les préfixes des fichiers sont affichés dans le sous-menu.

L’utilisateur clique sur un des fichiers ; ce ficher s'ouvre alors.

L’idée est de reproduire un menu s’ouvrant en cascade dans le style du menu « démarrer » de Windows (ici, 2 niveaux de menus déroulants). Je précise que je suis débutant sur VBA. Cette procédure sera associée à bouton, ce que je faire... C'est maigre mais déjà un début ! Si quelqu'un peu me donner le texte complet de la procédure c'est top ! Merci de vos réponses.

gillardg · Answer

1 tu postes pas dans le bon thème qui est Thèmes / Visual Basic 6 / Langages dérivés / VBA
alors que toi tu as posté dans VB.NET et VB 2005 / Divers / Aide & Documentation

2 tu  ne respectes pas le reglement puisque tu demandes un code tout fait au lieu de demander de l'aide sur un point précis de ton code 


 


bonne chance quand même 

Bonjour chez vous !

Teleron · Answer

Désolé, je découvre ce forum très bien mais qui,  il est vrai, necéssite de la rigueure dans la classement des messages. Sinon j'ai déjà fouiné un bon moment, j'ai trouvé des bribes de réponses mais étant débutant je ne sais pas rassembler les diverses procédures que j'ai déjà trouvé ici et là... 

Merci à ceux qui pourront tout de même me venir en aide !

lillith212 · Answer

Salut,

Tu as trouvé des brides de codes... ok, toi organise les et tests les. Si ca fonctionne c'est génial sinon, n'hesite pas à poster sur le forum en mettant ton code, ton message d'erreur etc... et la communauté t'aidera.
En demandant un code tout fait tu risques de te heurter à un mur. Car ce n'est pas le genre de la "maison".
Même si tu débutes, lance toi c'est ainsi que tu progressera. Si on te donne un code tout fait où est l'interêt de cet apprentissage???
Bon courage et surtout bon coding.

ps: Autre point du réglement, n'oubli pas de valider quand tu fais un post si la réponse t'a aidé ou t'a apporté la solution.

S.L.B.

<hr />****************************************************************

dedenet2 · Answer

Salut ,
voici un morceau de code qui permet de creer un menu et
3 sous menu:
il sera placé à coté du menu Aide.

------------------------------------------------------------
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 'Suppression Nouveau Menu
     Call SuppressionMenu_
 End Sub
------------------------------------------------------------
Private Sub Workbook_Open()
 'Affichage Nouveau Menu
     Call CréationMenu_
End Sub
------------------------------------------------------------
Sub CréationMenu_()
  Dim MenuAide As CommandBarControl
  Dim NouveauMenu As CommandBarPopup
  Dim SousMenu As CommandBarControl
 
'Trouver Menu Aide
Set MenuAide = CommandBars(1).FindControl(ID:=30010)
If MenuAide Is Nothing Then
    Set NouveauMenu = CommandBars(1).Controls.Add _
    (Type:=msoControlPopup, temporary:=True)
Else
    Set NouveauMenu = CommandBars(1).Controls.Add _
   (Type:=msoControlPopup, before:=MenuAide.Index, temporary:=True)
End If




'Ajout Menu Pricipal

      NouveauMenu.Caption = "&MenuPerso"
    
'Ajout sous-Menu
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlButton)
             With SousMenu
                  .Caption = "&Fichier1"
                  .FaceId = 66
                  .OnAction = "Fichier1"
                  
             End With
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlButton)
             With SousMenu
                  .Caption = "&Fichier2"
                  .FaceId = 42
                  .OnAction = "Fichier2"
             End With
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlButton)
             With SousMenu
                  .Caption = "&Fichier3"
                  .FaceId = 278
                  .OnAction = "Fichier3"
             End With
 
 
End Sub
-----------------------------------------------------------
Sub SuppressionMenu_()
 'Suppression Nouveau Menu
  On Error Resume Next
  Application.CommandBars(1).Controls("&MenuPerso").Delete
  'On Error GoTo 0
End Sub
--------------------------------------------------------------



Sub Fichier1()
   'Ecrire de code pour ouvrir le fichier concerné
    MsgBox "Pas de code"
End Sub
--------------------------------------------------------------
Sub fichier2()
   'Ecrire de code pour ouvrir le fichier concerné
   MsgBox "Pas de code"
End Sub
--------------------------------------------------------------
Sub fichier3()
   'Ecrire de code pour ouvrir le fichier concerné
   MsgBox "Pas de code"
End Sub
--------------------------------------------------------------
A toi de l'adapter à ton programme !
A++

Teleron · Answer

Salut

Merci beaucou, je vais tester l'ensemble et l'adapter à mon programme... J'étais sur les ComboBox mais là je pense que tu me fais gagner du temps. 

Encore merci, je reviens pour demander des explications ou pour expliquer j'ai résolu mon pb.

Teleron · Answer

Cette procédure m'a beaucoup aidé. Je viens de l'adapter de la manière suivante : j'ai ajouté dans la procédure SubFichier1() le programme permettant de lister les fichiers pdf d'un répertoire. 

Private Sub Workbook_BeforeClose(Cancel As Boolean)
 'Suppression Nouveau Menu
     Call SuppressionMenu_
 End Sub



-------------------------------------
Private Sub Workbook_Open()
 'Affichage Nouveau Menu
     Call CréationMenu_
End Sub



------------------------------------
Sub CréationMenu_()
  Dim MenuAide As CommandBarControl
  Dim NouveauMenu As CommandBarPopup
  Dim SousMenu As CommandBarControl
 
'Trouver Menu Aide
Set MenuAide = CommandBars(1).FindControl(ID:=30010)
If MenuAide Is Nothing Then
    Set NouveauMenu = CommandBars(1).Controls.Add _
    (Type:=msoControlPopup, temporary:=True)
Else
    Set NouveauMenu = CommandBars(1).Controls.Add _
   (Type:=msoControlPopup, before:=MenuAide.Index, temporary:=True)
End If



'Ajout Menu Pricipal
      NouveauMenu.Caption = "&MenuPerso"
    
'Ajout sous-Menu
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlButton)
             With SousMenu
                  .Caption = "&Fichier1"
                  .FaceId = 66
                  .OnAction = "Fichier1"
                  
             End With
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlButton)
             With SousMenu
                  .Caption = "&Fichier2"
                  .FaceId = 42
                  .OnAction = "Fichier2"
             End With
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlButton)
             With SousMenu
                  .Caption = "&Fichier3"
                  .FaceId = 278
                  .OnAction = "Fichier3"
             End With
 
 
End Sub



-----------------------------------------
Sub SuppressionMenu_()
 'Suppression Nouveau Menu
  On Error Resume Next
  Application.CommandBars(1).Controls("&Rapports d'audits").Delete
  'On Error GoTo 0
End Sub



--------------------------------------------
Sub Fichier1()
   
    Dim i As Integer
    With Application.FileSearch
        .NewSearch
        .LookIn = "
[file://\Cesar\sfc-divers\Audits\Rapport 
\Cesar\sfc-divers\Audits\Rapport
]
 d'audit"
        .SearchSubFolders = True
        .Filename = "*.pdf"
    End With



    With Application.FileSearch
        If .Execute() > 0 Then
            Range("A6").Select
            For i = 1 To .FoundFiles.Count
                ActiveCell.Value = .FoundFiles(i)
                ActiveCell.Offset(1, 0).Range("A1").Select
            Next i
        Else
            MsgBox "Aucun fichier correspondant à ce critère"
        End If
        Range("A6").Select
    End With
 
End Sub



----------------------------------------------------------
Sub Fichier2()
   'Ecrire de code pour ouvrir le fichier concerné
   MsgBox "Pas de code"
End Sub



-------------------------------------------------------------
Sub Fichier3()
   'Ecrire de code pour ouvrir le fichier concerné
   MsgBox "Pas de code"
End Sub

--------------------------------------------------------------



J'ai ensuite cherché à effectuer, sans résultat, 2 modifications pour aboutir à :

- Faire en sorte que le menu initial se déroule en cliquant sur une image que j'aurais inséré sur la feuille Excel et auquelle j'aurais affecté la procédure Sub CréationMenu_(). A défaut ce menu pourrait s'afficher sur une celllule de la feuille (par exemple A1),

- Faire en sorte que les fichiers s'affichent dans un nouveau sous-menu du sous menu Fichier1 (je déclinerai les Fichiers 2 et 3 ensuite). Je pense voir comment les ouvrir lorsque l'on clique dessus...

Merci encore pour ce code qui m'a bien fait avancé. Je suis preneur de la résolution des 2 point qui me posent encore pb !

Téléron

dedenet2 · Answer

Bonjour ,

Voici un menu flottant quand tu cliques sur une image:
-----------------------------------------------------------
Private Sub Image1_Click()
'supprime CommandBar
  CommandBars("Fichiers").Visible = True
'Position depuis bord gauche et haut
  CommandBars("Fichiers").Left = 100
  CommandBars("Fichiers").Top = 300
End Sub
-------------------------------------------------------------
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 'Suppression Menu bar
     Call SuppressionBarMenu
 End Sub
-------------------------------------------------------------
Private Sub Workbook_Open()
 'Creation Menubar
     Call CréationBarMenu
 End Sub
--------------------------------------------------------------
Option Explicit
 
Sub CréationBarMenu()



Dim mybar, i
Dim NouveauMenu As CommandBarPopup
Dim SousMenu As CommandBarControl
Dim SousSousMenu As CommandBarButton



On Error Resume Next
CommandBars("Fichiers").Delete
On Error GoTo 0
'création barre de menu
Set mybar = CommandBars.Add(Name:="Fichiers", _
                        Position:=msoBarFloating, Temporary:=True)
                      
'Création menu principal
Set NouveauMenu = CommandBars("Fichiers"). _
                  Controls.Add(Type:=msoControlPopup, Temporary:=True)
    NouveauMenu.Caption = "Fichiers"
      
  
'Ajout sous-Menu
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlPopup)
    With SousMenu
        .Caption = "&*.xls"
    End With
    For i = 1 To 10
    Set SousSousMenu = SousMenu.Controls.Add(Type:=msoControlButton)
        With SousSousMenu
            .Caption = "Fichier " & i
            .FaceId = 66
          
        End With
    Next
 
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlPopup)
             With SousMenu
                  .Caption = "&*.doc"
            End With
    For i = 1 To 10
    Set SousSousMenu = SousMenu.Controls.Add(Type:=msoControlButton)
        With SousSousMenu
            .Caption = "Fichier " & i
            .FaceId = 42
           
        End With
    Next
            
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlPopup)
             With SousMenu
                  .Caption = "&*.pdf"
             End With
     For i = 1 To 10
     Set SousSousMenu = SousMenu.Controls.Add(Type:=msoControlButton)
        With SousSousMenu
            .Caption = "Fichier " & i
            .FaceId = 278
           
        End With
     Next
   
End Sub
------------------------------------------------------------
Sub SuppressionBarMenu()
On Error Resume Next
   CommandBars("Fichiers").Delete
On Error GoTo 0
End Sub
-------------------------------------------------------------
Il te reste à rajouter
    - listing des fichiers pour chaque sous menu
    - Les evenements "clique" pour ouverture des fichiers.
      (Cherche sur onAction et index).
C'est en cherchant qu'on retiens !

           

Bonne Programmation
A++

Teleron · Answer

Extra ! Merci, je vais regarder ça de près pour modifier mon progr. Merci encore, je reviens pour donner des news.


Téléron

Teleron · Answer

Bonjour ! Je viens de mettre à profit ton code dedenet2 et j'ai tenté de faire apparaitre dans le 2è sous menu,  la liste des fichiers  *.pdf . Aucune erreur n'est affichée mais le sous-sous menu correspondant apparait comme vide. Ai-je oublié quelque chose ?

Sinon j'ai une petite question : il semble que l'on ne puisse pas mettre de "sub" dans une "sub". Est-ce que je me trompe ?

Une fois que j'aurais réussi à afficher la lisye des fichiers, il ne me restera plus qu'à les ouvrir en cliquant dessus. Je chercherai avec la piste que tu m'a donné.


 


merci de ton aide en tout cas

Teleron · Answer

Voici le code que j'ai ajouté pour afficher la liste des fichiers .pdf dans le sous sous menu (je précise qu'il y a des fichiers .pdf dans le repertoire ciblé par le chemin !) :

---------------------------
Sub CréationBarMenu()


Dim mybar, i
Dim NouveauMenu As CommandBarPopup
Dim SousMenu As CommandBarControl
Dim SousSousMenu As CommandBarButton
Dim j As Integer


On Error Resume Next
CommandBars("Rapports d'audits").Delete
On Error GoTo 0
'création barre de menu
Set mybar = CommandBars.Add(Name:="Rapports d'audits", _
                        Position:=msoBarFloating, Temporary:=True)
                      
'Création menu principal
Set NouveauMenu = CommandBars("Rapports d'audits"). _
                  Controls.Add(Type:=msoControlPopup, Temporary:=True)
    NouveauMenu.Caption = "Rapports d'audits"
      
  
'Ajout sous-Menu
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlPopup)
    With SousMenu
        .Caption = "Tableaux d'audits achat"
    End With
    For i = 1 To 10
    Set SousSousMenu = SousMenu.Controls.Add(Type:=msoControlButton)
        With SousSousMenu
            .Caption = "Fichier " & i
            .FaceId = 66
          
        End With
    Next
 
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlPopup)
             With SousMenu
                  .Caption = "Rapports d'audits en cours"
            End With
    
        
        Set SousSousMenu = SousMenu.Controls.Add(Type:=msoControlButton)
        With SousSousMenu
            With Application.FileSearch
            
                .NewSearch
                .LookIn = "c:\rapports d'audit"
                .SearchSubFolders = True
                .Filename = "*.pdf"
                For j = 1 To .FoundFiles.Count
             
                    .Caption = "Fichier" & .FoundFiles(j)
                    .FaceId = 42
                
                Next j
                            
            End With
        End With
         
            
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlPopup)
             With SousMenu
                  .Caption = "&Rapports d'audits clos"
             End With
     For i = 1 To 5
     Set SousSousMenu = SousMenu.Controls.Add(Type:=msoControlButton)
        With SousSousMenu
            .Caption = "Fichier " & i
            .FaceId = 278
           
        End With
     Next
   
End Sub

dedenet2 · Answer

Salut ,
En effet , on ne peux pas mettre un sub dans un
sub.
A+

Teleron · Answer

Salut. Tout d'abord, merci à tous. Avec votre aide, de la sueur et après quelque sjours de vacances, j'ai aboutit à, presque, ce que je voulais :
- créer un menu et des sous menu permettant de rechercher les fichier .xls, .doc, .pdf.

Il reste une chose que je ne parviens pas à faire : lancer le fichier choisi dans le menu déroulant. Je sais que je dois utiliser OnAction = 

Je n'arrive pas à associer Workbooks.Open Filename:= .FoundFiles(i) ca serait trop simple... Peut-être faut-il appeler une procédure mais je ne sais pas l'écrire


Comment ouvrir un classeur .xls ou doc et pdf de ce menu...? 
Merci encore pour votre aide !


Voici le code où il en est :
-----------------------
Option Explicit
 -----------------
Sub CréationBarMenu()


Dim mybar, i
Dim NouveauMenu As CommandBarPopup
Dim SousMenu As CommandBarControl
Dim SousSousMenu As CommandBarButton
Dim j As Integer
Dim m_fileName As String




On Error Resume Next
CommandBars("Rapports d'audits").Delete
On Error GoTo 0
'création barre de menu
Set mybar = CommandBars.Add(Name:="Rapports d'audits", _
                        Position:=msoBarFloating, Temporary:=True)
                      
'Création menu principal
Set NouveauMenu = CommandBars("Rapports d'audits"). _
                  Controls.Add(Type:=msoControlPopup, Temporary:=True)
    NouveauMenu.Caption = "Rapports d'audits"
      
  
'Ajout sous-Menus
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlPopup)
             With SousMenu
                  .Caption = "&Rapports d'audits clos"
                 
             End With
             
              With Application.FileSearch
            .NewSearch
            .LookIn = "F:\OLGA\Rapports d'audits"
            .SearchSubFolders = True
            .Filename = "*.pdf"
            End With
    
    With Application.FileSearch
        If .Execute() > 0 Then
            
            For i = 1 To .FoundFiles.Count
                 
                 m_fileName = Strings.Mid$(.FoundFiles(i), Strings.InStrRev(.FoundFiles(i), "") + 1)
                 
            
                Set SousSousMenu = SousMenu.Controls.Add(Type:=msoControlButton)
                With SousSousMenu
                    
                    .Caption = m_fileName
                    .FaceId = 1757
                    '.OnAction = ouvrir le fichier .pdf                              
                End With
               
            Next
        Else
            MsgBox "Aucun fichier correspondant à ce critère"
        End If
        
    End With
     
   


Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlPopup)
    With SousMenu
        .Caption = "Tableaux d'audits achat"
    End With
    
    With Application.FileSearch
        .NewSearch
        .LookIn = "F:\OLGA\Rapports d'audits"
        .SearchSubFolders = True
        .Filename = "*.xls"
    End With
    
    
    With Application.FileSearch
        If .Execute() > 0 Then
            
            For i = 1 To .FoundFiles.Count
                 
                 m_fileName = Strings.Mid$(.FoundFiles(i), Strings.InStrRev(.FoundFiles(i), "") + 1)




            
                Set SousSousMenu = SousMenu.Controls.Add(Type:=msoControlButton)
                With SousSousMenu
                    
                    .Caption = m_fileName
                    .FaceId = 66
                     '.OnAction = ouvrir le fichier .xls                                 
                End With
               
            Next
        Else
            MsgBox "Aucun fichier correspondant à ce critère"
        End If
        
    End With
    
    
 
Set SousMenu = NouveauMenu.Controls.Add(Type:=msoControlPopup)
             With SousMenu
                  .Caption = "Rapports d'audits en cours"
            End With
            
            With Application.FileSearch
            .NewSearch
            .LookIn = "F:\OLGA\Rapports d'audits"
            .SearchSubFolders = True
            .Filename = "*.doc"
            End With
    
    With Application.FileSearch
        If .Execute() > 0 Then
            
            For i = 1 To .FoundFiles.Count
                 
                 m_fileName = Strings.Mid$(.FoundFiles(i), Strings.InStrRev(.FoundFiles(i), "") + 1)


            
                Set SousSousMenu = SousMenu.Controls.Add(Type:=msoControlButton)
                With SousSousMenu
                    
                    .Caption = m_fileName
                    .FaceId = 42
                   '.OnAction = ouvrir le fichier .pdf   
                              
                End With
               
            Next
        Else
            MsgBox "Aucun fichier correspondant à ce critère"
        End If
        
    End With
 End Sub


-----------------------
Sub SuppressionBarMenu()
On Error Resume Next
   CommandBars("Rapports d'audits").Delete
On Error GoTo 0
End Sub


-----------------

VBA Excel procédure créant un menu déroulant listant des fichiers à ouvrir

12 réponses

Votre réponse

Discussions similaires