Titre du sujet : Re: Créer et Utiliser des listes de choix successives
par myDearFriend! le 14/10/2009 23:16:33
Re,
Je résume un peu les choses...
En Feuil1, colonne F, tu as ta liste de liens pointant sur les fichiers images stockés sur le disque dur (liens de type = File:///..... )
Ton module de code standard Module1, ressemble maintenant à ceci :
Option Explicit
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)
'----------------------------------------------
' 2pme, 9 octobre 2009
'----------------------------------------------
Dim picImage As StdPicture
Dim strURL As String
Dim lngH As Long, lngL As Long
strURL = Feuil1.Cells(L + 2, 6).Hyperlinks(1).Address
On Error Resume Next
shaImage.Delete ' Pour se débarasser de l'image précédente
On Error GoTo 0
Set picImage = LoadPicture(strURL)
lngH = picImage.Height / 100
lngL = picImage.Width / 100
Set shaImage = Feuil2.Shapes.AddPicture(strURL, msoTrue, msoFalse, 200, 10, lngL, lngH)
With shaImage
.LockAspectRatio = msoTrue ' Assure une taille proportionnelle
.Height = 200 ' Unités : points. Tu peux ajuster selon ta préférence.
End With
End Sub
Si tes liens sont corrects en Feuil1, alors il n'y a aucune raison pour que ça ne fonctionne pas...
Cordialement,
|
Didier FOURGEOT