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.
|