XL 2019 Générer la photo dans un autre onglet

[Agar]

Bonjour à tous,
Je me permet de vous solliciter car depuis quelques jours je suis confronté à un problème que je ne sais pas résoudre.

En gros je souhaiterai que l'image que j'ai stocké dans un dossier sur mon ordinateur puisse être d'une part archivé dans le tableau (chemin d'accès jusqu'à mon repertoire) d'autre part visible dans l'onglet fiche à la place que j'ai indiqué.

J'ai réussi à générer le lien dans une colonne spécifique du classeur (Feuil1) mais je n'arrive pas à générer simultanément l'image à l'endroit prévu en feuille 2 (Fiche)

J'éspère que mon problème est assez clair
Je vous joins mon fichier

Merci

 

[job75]

Bonjour Agar, bienvenue sur XLD,

Je suppose que comme sur l'exemple les chemins d'accès des photos sont en colonne E de Feuil1.

Placez dans le code de cette feuille (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 5 Or Dir(CStr(Target)) = "" Then Exit Sub
Dim r As Range, s As Shape
Cancel = True
With Sheets("Fiche")
    Set r = .[B6:F18] 'plage à adapter
    For Each s In .Shapes
        If Not Intersect(s.TopLeftCell, r) Is Nothing Then s.Delete
    Next
    With .Pictures.Insert(CStr(Target))
        .ShapeRange.LockAspectRatio = True
        .Height = r.Height - 4
        If .Width > r.Width - 4 Then .Width = r.Width - 4
        .Left = r.Left + (r.Width - .Width) / 2
        .Top = r.Top + (r.Height - .Height) / 2
    End With
    .Activate 'facultatif
End With
End Sub

La macro s'exécute quand on fait un double-clic en colonne E.

A+

 

[Agar]

Un grand merci job75 pour ce retour si rapide.
Seulement voila en essayant de le mettre dans le fichier comportant d'autres macro celle-ci ne fonctionne plus.

Penses-tu que ce soit du fait qu'il y ait trop de private Sub sur la feuille ?
As tu une astuce pour pouvoir les faire fonctionner en même temps ?

Encore merci

 

[job75]

Bonjour Agar,

Il n'est pas possible d'avoir 2 macros Worksheet_BeforeDoubleClick dans la même feuille !!!

Alors soit vous supprimez la 2ème soit vous utilisez le clic droit et cette macro :

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 5 Or Dir(CStr(Target(1))) = "" Then Exit Sub
Dim r As Range, s As Shape
Cancel = True
With Sheets("Fiche")
    Set r = .[B6:F18] 'plage à adapter
    
    For Each s In .Shapes
        If Not Intersect(s.TopLeftCell, r) Is Nothing Then s.Delete
    Next
    With .Pictures.Insert(CStr(Target(1)))
        .ShapeRange.LockAspectRatio = True
        .Height = r.Height - 4
        If .Width > r.Width - 4 Then .Width = r.Width - 4
    
        .Left = r.Left + (r.Width - .Width) / 2
        .Top = r.Top + (r.Height - .Height) / 2
    End With
    .Activate 'facultatif
End With
End Sub

Attention, recopiez exactement la macro (dans la BeforeDoubleClick vous aviez oublié s.Delete).

A+

 

[Agar]

ça marche super !!! merci pour la petite astuce du clic droit, je l'à réutiliserais
Encore merci à vous et à ce forum.

 

[job75]

Notez qu'il est possible de regrouper dans la même macro les codes des 2 BeforeDoubleClick.

Il suffit de bien distinguer les 2 plages d'exécution.

Je ne l'ai pas fait parce que votre fichier est incomplet.