Rapport de message :*
 

Re: Créer et Utiliser des listes de choix successives

Titre du sujet : Re: Créer et Utiliser des listes de choix successives
par gmarin le 14/10/2009 23:34:00

Option Explicit

' 2pme, 9 octobre 2009
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Dim shaImage As Shape


'---------------------------------------------------------------------------------------
' Auteur    : Didier FOURGEOT (myDearFriend!)  -  www.mdf-xlpages.com
' Date      : 07/10/2009
' Sujet     : Menu en cascade
'---------------------------------------------------------------------------------------
Sub AffichMenuD(T As String)
Dim CB As CommandBar
Dim M As CommandBarPopup, M1 As CommandBarPopup, M2 As CommandBarButton
Dim TabTemp
Dim L&
    If T = "" Then Exit Sub
    'On m�morise la liste des donn�es (en plage A3:F? ici)
    With Sheets("Feuil1")
        L = .Cells(.Rows.Count, 1).End(xlUp).Row
        TabTemp = .Range(.Cells(3, 1), .Cells(L, 6)).Value
    End With
    'On cr�e une barre de menu temporaire
    On Error Resume Next
    Application.CommandBars("MenuD").Delete
    On Error GoTo 0
    Set CB = Application.CommandBars.Add("MenuD", msoBarPopup, , True)
    For L = 1 To UBound(TabTemp, 1)
        If UCase(TabTemp(L, 4)) Like T & "*" Then
            '1er niveau du menu (�l�ments en colonne 4 sur la feuille)
            Set M = ElmtMenu(TabTemp(L, 4), CB, True)
            '2�me niveau du menu (�l�ments en colonne 6 sur la feuille)
            Set M1 = ElmtMenu(TabTemp(L, 6), M, True)
            '3�me niveau du menu (�l�ments en colonne 1 sur la feuille)
            Set M2 = ElmtMenu(TabTemp(L, 1), M1, False)
            M2.OnAction = "'SuivreLien " & L & "'"
        End If
    Next L
    'Affiche le menu
    With Application.CommandBars("MenuD")
        If .Controls.Count > 0 Then .ShowPopup
        .Delete
    End With
End Sub

Private Function ElmtMenu(ByVal T$, MenuParent As Object, Pop As Boolean) As Object
Dim M As CommandBarControl
    On Error Resume Next
    Set M = MenuParent.Controls(T)
    On Error GoTo 0
    If M Is Nothing Then
        Set M = MenuParent.Controls.Add(IIf(Pop, msoControlPopup, msoControlButton), , , , True)
        M.Caption = T
    End If
    Set ElmtMenu = M
End Function

Sub SuivreLien(L As Long)

  Dim strExt As String
  Dim strtabBidon() As String
  Dim strURL As String
  Dim lngH As Long
  Dim lngL As Long
 
   
    strURL = Feuil1.Cells(L + 2, 6).Hyperlinks(1).Address
    strtabBidon = Split(strURL, ".")
    strExt = strtabBidon(UBound(strtabBidon))
   
    If TelechargerImage(strURL, DossierTempo & "Image." & strExt, lngH, lngL) Then
     
      On Error Resume Next
      shaImage.Delete
      On Error GoTo 0
     
      ' Modifier les param�tre Top, Left, Height et Width au besoin.
      Set shaImage = Feuil2.Shapes.AddPicture(DossierTempo & "Image." & strExt, msoTrue, msoFalse, 220, 100, lngL, lngH)
      With shaImage
      .LockAspectRatio = msoTrue ' Assure une taille proportionnelle
          .Height = 400 ' Unit� : point.  J'ai mis 200 au pifom�tre. Tu peux ajuster selon ta pr�f�rence.
     
      End With
    Else
   
      'Pour un fonctionnement "classique" (=visualisation dans le navigateur web),
      'il convient d'activer la ligne ci-dessous (et d�sactiver les suivantes) :
          ' ThisWorkbook.FollowHyperlink Sheets("Feuil1").Cells(L + 2, 6).Hyperlinks(1).Address
         
      ' 2pme, 9 octobre 2009
      ' Supprimer le commentaire d'une des deux m�thode pour le cas o� l'image ne serait pas t�l�charg�e correctement
     
         
      'Pour un fonctionnement avec contr�le WebBrowser directement sur la feuille Excel :
      '    Sheets("Feuil2").WebBrowser1.Navigate Sheets("Feuil1").Cells(L + 2, 6).Hyperlinks(1).Address
   
    End If
   
End Sub

' 2pme, 9 octobre 2009
Function DossierTempo() As String

  DossierTempo = Environ("Temp") & "\"
  ' Autre possibilit�
'  DossierTempo = ThisWorkbook.Path & "\"

End Function

' 2pme, 9 octobre 2009
Function TelechargerImage(URL As String, FichierLocal As String, Hauteur As Long, Largeur As Long) As Boolean
 
  Dim picImage As StdPicture
 
  If URLDownloadToFile(0, URL, FichierLocal, 0, 0) = 0 Then
   
    Set picImage = LoadPicture(FichierLocal)
    Hauteur = picImage.Height / 100 ' Donn�e au format HMETRIC � transformer en point. Donne de bons r�sultats tel quel pour l'heure
                                    ' � peaufiner.
    Largeur = picImage.Width / 100
    TelechargerImage = True
   
  Else
 
    TelechargerImage = False
   
  End If
 
End Function
Actuellement, c'est ce que j'ai.