Re: Créer et Utiliser des listes de choix successives
#51
Accro XLPages

Inscription: 09/01/2008
De Montréal, Québec

Messages: 463

Système d'exploitation:
PC
Version Excel utilisée:
97 à 2016
Posté le : 14-10-2009 20h53
Effectivement Didier,

Tout ça est bien long et aurait dû être posé correctement dès le début.

Guy

Hors Ligne
Rapport   Haut 

Re: Créer et Utiliser des listes de choix successives
#52
Régulier XLPages

Inscription: 05/10/2009
De 33210-Gironde

Messages: 49

Système d'exploitation:
PC
Version Excel utilisée:
2007
Posté le : 14-10-2009 20h59
Citation :
Guy a écrit : Je ne crois pas que ce soit nécessaire finalement.

Est-ce que tu prévois utiliser des fichiers locaux et des fichiers web simultanément?

Guy

Uniquement fichiers locaux ...

Hors Ligne
Rapport   Haut 

Re: Créer et Utiliser des listes de choix successives
#53
Accro XLPages

Inscription: 09/01/2008
De Montréal, Québec

Messages: 463

Système d'exploitation:
PC
Version Excel utilisée:
97 à 2016
Posté le : 14-10-2009 21h05
Tests faits, et j'aurais dû le voir illico (honte sur moi), il suffit de modifier les liens en feuille 1.

Simplement passer de 'http://www.truc.chose/Image.jpg à 'file:///C:/Mondossier/Images/PourGmarin/Image.jpg et, sur mon poste à tout le moins, la chose roule à merveille.

Je ne vois donc pas pourquoi ça ne fonctionne pas sur ton poste...

Guy

Hors Ligne
Rapport   Haut 

Re: Créer et Utiliser des listes de choix successives
#54
Régulier XLPages

Inscription: 05/10/2009
De 33210-Gironde

Messages: 49

Système d'exploitation:
PC
Version Excel utilisée:
2007
Posté le : 14-10-2009 21h50
Mes liens sont bien sûr modifiés vers le répertoire local. (file:///.....
Si je les teste dans la feuille 1, les liens s'ouvrent bien dans Internet Explorer.
Si je les scrute par la feuille2, les menus se déploient normalement, mais aucun affichage n'arrive.
Hors Ligne
Rapport   Haut 

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

Inscription: 18/05/2006
De Saône-et-Loire (71)

Messages: 1521

Système d'exploitation:
PC
Version Excel utilisée:
97, 2000, 2002, 2003, 2007, 2010, 2013, 2016 et 365
Posté le : 14-10-2009 23h16
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_mDF
Image redimensionnée
Le Webmaster

La réponse vous satisfait ? Merci de revenir solder le sujet en [résolu], voir ce lien
Hors Ligne
Rapport   Haut 

Re: Créer et Utiliser des listes de choix successives
#56
Régulier XLPages

Inscription: 05/10/2009
De 33210-Gironde

Messages: 49

Système d'exploitation:
PC
Version Excel utilisée:
2007
Posté le : 14-10-2009 23h34
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.
Hors Ligne
Rapport   Haut 

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

Inscription: 18/05/2006
De Saône-et-Loire (71)

Messages: 1521

Système d'exploitation:
PC
Version Excel utilisée:
97, 2000, 2002, 2003, 2007, 2010, 2013, 2016 et 365
Posté le : 14-10-2009 23h39
Citation :
gmarin a écrit :
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.

Et tu n'as pas envie d'essayer comme je te l'indique plus haut ?


Didier_mDF
Image redimensionnée
Le Webmaster

La réponse vous satisfait ? Merci de revenir solder le sujet en [résolu], voir ce lien
Hors Ligne
Rapport   Haut 

Re: Créer et Utiliser des listes de choix successives
#58
Régulier XLPages

Inscription: 05/10/2009
De 33210-Gironde

Messages: 49

Système d'exploitation:
PC
Version Excel utilisée:
2007
Posté le : 15-10-2009 00h05
Désolé, je sais plus tellement où j'en suis sur ce module.
Je vais donc essayer de le modifier avec cette dernière proposition.

Hors Ligne
Rapport   Haut 

Re: Créer et Utiliser des listes de choix successives
#59
Régulier XLPages

Inscription: 05/10/2009
De 33210-Gironde

Messages: 49

Système d'exploitation:
PC
Version Excel utilisée:
2007
Posté le : 15-10-2009 20h07
Bonsoir Didier,

Désolé :
Message : erreur d'exécution 75 -  chemin d'accès introuvable
ligne surlignée en jaune dans "Sub SuivreLien(L as LOng) : Set picImage = LoadPicture(strURL).

Une des causes citées dans l'aide proposée est une erreur entre chemin relatif et absolu
En regardant les liens hypertexte, ceux-ci sont en chemin relatif.
Le fichier excel et le répertoire des photos étant dans le même chemin.
J'ai déplace mon répertoire photos dans une autre unité.
J'ai mis le chemin absolu sur une série de liens.

Là, çà fonctionne très bien.

Mais, je ne peux pas laisser ce répertoire déplacé, il doit être à côté du fichier excel.
Hors Ligne
Rapport   Haut 

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

Inscription: 18/05/2006
De Saône-et-Loire (71)

Messages: 1521

Système d'exploitation:
PC
Version Excel utilisée:
97, 2000, 2002, 2003, 2007, 2010, 2013, 2016 et 365
Posté le : 15-10-2009 21h27
Bonsoir gmarin, Guy, le Forum,

Pffffiiouuu, on va peut-être y arriver cette fois...

Bon, toujours en partant du code que je t'ai présenté plus haut, modifie la procédure SuivreLien() comme suit :
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
    If InStr(strURL, ":") = 0 Then
        strURL = ThisWorkbook.Path & "\" & strURL
    End If

    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 : point. Tu peux ajuster selon ta préférence.
    End With
End Sub

Cordialement,

Didier_mDF
Image redimensionnée
Le Webmaster

La réponse vous satisfait ? Merci de revenir solder le sujet en [résolu], voir ce lien
Hors Ligne
Rapport   Haut 


Vous pouvez voir les sujets.
Vous ne pouvez pas débuter de nouveaux sujets.
Vous ne pouvez pas répondre aux contributions.
Vous ne pouvez pas éditer vos contributions.
Vous ne pouvez pas effacez vos contributions.
Vous ne pouvez pas ajouter de nouveaux sondages.
Vous ne pouvez pas voter en sondage.
Vous ne pouvez pas attacher des fichiers à vos contributions.
Vous ne pouvez pas poster sans approbation.

[Recherche avancée]


Qui consulte actuellement ce sujet ?   1 Utilisateur(s) anonymes