XL 2013 Image au survol d'une cellule

[maval]

Bonjour,

J'ai un dossier avec un fichier nommé "Image" ou il y a des photos en JPG.
Dans mon classeur j'ai en feuil1 les noms des acteurs "B2:B1000" et j'aimerais que lorsque je passe mon curseur sur un nom d'acteur sa photo s'affiche.

Je vous remercie de votre aide

 

[chris]

Re : Image au survol d'une cellule

Bonjour

Il n'y a pas d'événement lié au survol de cellule.
Il faut ajouter une forme pour détecter le survol : vois si cela est envisageable sinon clic droit ou double clic

 

[maval]

Re : Image au survol d'une cellule

Bonjour Chris

Oui si cela est possible?

 

[Modeste geedee]

Re : Image au survol d'une cellule

Bonsour®

Il n'y a pas d'événement lié au survol de cellule.

mais si ...
l'affichage commentaire !


il suffit pour cela d'insérer en fond de commentaire l'image souhaitée


hélas comme le demandeur n'a pas fourni l'onglet avec les images (nom des images)
je n'ai pas écrit la macro qui permet d'associer l'image au commentaire correspondant au nom du sujet


pas le temps d'aller à la pèche aux images pour étayer mon propos...
faut que j'aille à la pèche à la truite pour le barbecue de ce soir...

 

[mutzik]

Re : Image au survol d'une cellule

bonjour à tous

voir sur l'excellent site de Jacques
Formation Excel VBA JB
rubrique Commentaires

 

[BOISGONTIER]

Re : Image au survol d'une cellule

Bonjour,

Gestion des événements (survol cellule)

JB

 

[maval]

Re : Image au survol d'une cellule

Bonjour JB

Je vous remercie, j'aimerai savoir ou se trouve les photos et comment programmer pour 1000 cellules environ

Je vous remercie d'avance

 

[BOISGONTIER]

Re : Image au survol d'une cellule

http://boisgontierjacques.free.fr/pages_site/commentaire.htm#CmtPhoto5

http://boisgontierjacques.free.fr/fichiers/Commentaires/PhotosCommentaire.xls

Boisgontier

 

[job75]

Re : Image au survol d'une cellule

Bonsoir maval, chris, Modeste geedee, mutzik, JB,

Il vous faudra traiter chaque acteur un par un, avec 2 doubles-clics

Voyez le fichier joint et cette macro :

Private Sub Worksheet_BeforeDoubleClick(ByVal c As Range, Cancel As Boolean)
Dim chemin$, urlBase$, a, o As Object
Cancel = True
chemin = ActiveWorkbook.Path & "\Photos acteurs\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'creation du sous-dossier
If Dir(chemin & c & ".png") = "" Then
  urlBase = "https://www.google.fr/search?hl=fr&site=imghp&tbm=isch&q=" & Replace(c, " ", "+")
  a = Shell("C:\Program Files\Internet Explorer\iexplore.exe " & urlBase, vbNormalFocus)
Else
  Application.ScreenUpdating = False
  Set o = Me.Pictures.Insert(chemin & c & ".png") 'image temporaire
  c.ClearComments
  c.AddComment
  c.Comment.Shape.Width = o.Width
  c.Comment.Shape.Height = o.Height
  c.Comment.Shape.Fill.UserPicture chemin & c & ".png"
  o.Delete
End If
End Sub

Procedure :

1) 1er double-clic sur un nom pour aller sur le site web.

2) Clic droit sur l'image choisie => Enregistrer l'image sous.

Sous le nom exact se trouvant dans la cellule cliquée et dans le répertoire Photos acteurs

3) 2ème double-clic pour créer le commentaire avec l'image.

Remarques :

- l'étape 2) ne peut pas être automatisée

- a priori les photos du site web sont des fichiers .png

- la création de l'image (temporaire) dans la feuille permet de connaître ses dimensions.

Bonne fin de soirée.

 

[job75]

Re : Image au survol d'une cellule

Re,

Sur le site web il y a aussi des images .jpg (JPEG) donc prenez ce fichier (2) avec :

Private Sub Worksheet_BeforeDoubleClick(ByVal c As Range, Cancel As Boolean)
Dim chemin$, urlBase$, a, o As Object
Cancel = True
chemin = ActiveWorkbook.Path & "\Photos acteurs\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'creation du sous-dossier
If Dir(chemin & c & ".png") = "" And Dir(chemin & c & ".jpg") = "" Then
  urlBase = "https://www.google.fr/search?hl=fr&site=imghp&tbm=isch&q=" & Replace(c, " ", "+")
  a = Shell("C:\Program Files\Internet Explorer\iexplore.exe " & urlBase, vbNormalFocus)
Else
  Application.ScreenUpdating = False
  On Error Resume Next
  Set o = Me.Pictures.Insert(chemin & c & ".png") 'image temporaire, celle-ci
  Set o = Me.Pictures.Insert(chemin & c & ".jpg") 'sinon celle-la
  c.ClearComments
  c.AddComment
  c.Comment.Shape.Width = o.Width
  c.Comment.Shape.Height = o.Height
  c.Comment.Shape.Fill.UserPicture chemin & c & ".png" 'ceci
  c.Comment.Shape.Fill.UserPicture chemin & c & ".jpg" 'sinon cela
  o.Delete
End If
End Sub

Bonne nuit.

 

[maval]

Re : Image au survol d'une cellule

Bonjour Job

J'ai un souci j'ai pris le fichier du post 10 et j'ai créer un répertoire sur mon bureau "Photos acteurs" delà j'ai double-clic sur un nom pour aller sur le site web, Enregistrer l'image sous avec le même orthographe de la cellule, la photo est bien dans mon répertoire "Photos acteurs" avec son nom exact en JPG.
J'ai ajouter un commentaire au nom mais comment faire un deuxième double-clic?

Je vous remercie et bonne journée

 

[job75]

Re : Image au survol d'une cellule

Bonjour maval, le forum,

Pour créer plusieurs photos d'un même acteur enregistrez la photo avec son nom + <espace> + ajout.

Vous entrerez les ajouts dans les cellules à droite du nom, exemple 1970 en C20.

Faites le 2ème double-clic sur l'ajout pour créer le commentaire.

Fichier (3) avec cette nouvelle macro :

Private Sub Worksheet_BeforeDoubleClick(ByVal c As Range, Cancel As Boolean)
Dim chemin$, nom$, nomA$, urlBase$, a, o As Object
If c = "" Then Exit Sub
Cancel = True
chemin = ActiveWorkbook.Path & "\Photos acteurs\"
nom = c(1, 3 - c.Column) 'nom en colonne B
nomA = chemin & nom & IIf(c.Column > 2, " " & c, "") 'nom + ajout
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'creation du sous-dossier
If Dir(nomA & ".png") & Dir(nomA & ".jpg") = "" Then
  urlBase = "https://www.google.fr/search?hl=fr&site=imghp&tbm=isch&q=" & Replace(nom, " ", "+")
  a = Shell("C:\Program Files\Internet Explorer\iexplore.exe " & urlBase, vbNormalFocus)
Else
  Application.ScreenUpdating = False
  On Error Resume Next
  Set o = Me.Pictures.Insert(nomA & ".png") 'image temporaire, celle-ci
  Set o = Me.Pictures.Insert(nomA & ".jpg") 'sinon celle-la
  c.ClearComments
  c.AddComment
  c.Comment.Shape.Width = o.Width
  c.Comment.Shape.Height = o.Height
  c.Comment.Shape.Fill.UserPicture nomA & ".png" 'ceci
  c.Comment.Shape.Fill.UserPicture nomA & ".jpg" 'sinon cela
  o.Delete
End If
End Sub

Edit : ajouté If c = "" Then Exit Sub au début.

Bonne journée.

 

[job75]

Re : Image au survol d'une cellule

Re,

Pour peaufiner :

- affichage/masquage des ajouts par double-clic en B1

- suppression du commentaire et du fichier de l'image par clic droit.

Private Sub Worksheet_BeforeDoubleClick(ByVal c As Range, Cancel As Boolean)
Dim P As Range, chemin$, nom$, nomA$, url$, a, o As Object
If c.Address = "$B$1" Then
  Cancel = True
  For Each c In Me.UsedRange.Rows(1).Cells
    If c Like "ajout*" Then Set P = Union(IIf(P Is Nothing, c, P), c)
  Next
  If Not P Is Nothing Then P.EntireColumn.Hidden = Not P(1).EntireColumn.Hidden
ElseIf c.Row > 1 And c.Column > 1 And c <> "" Then
  Cancel = True
  chemin = ActiveWorkbook.Path & "\Photos acteurs\"
  nom = c(1, 3 - c.Column) 'nom en colonne B
  nomA = chemin & nom & IIf(c.Column > 2, " " & c, "") 'nom + ajout
  If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'creation du sous-dossier
  If Dir(nomA & ".png") & Dir(nomA & ".jpg") = "" Then
    url = "https://www.google.fr/search?hl=fr&site=imghp&tbm=isch&q=" & Replace(nom, " ", "+")
    a = Shell("C:\Program Files\Internet Explorer\iexplore.exe " & url, vbNormalFocus)
  Else
    Application.ScreenUpdating = False
    On Error Resume Next
    Set o = Me.Pictures.Insert(nomA & ".png") 'image temporaire, celle-ci
    Set o = Me.Pictures.Insert(nomA & ".jpg") 'sinon celle-la
    c.ClearComments
    c.AddComment
    c.Comment.Shape.Width = o.Width
    c.Comment.Shape.Height = o.Height
    c.Comment.Shape.Fill.UserPicture nomA & ".png" 'ceci
    c.Comment.Shape.Fill.UserPicture nomA & ".jpg" 'sinon cela
    o.Delete
  End If
End If
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal c As Range, Cancel As Boolean)
If c.Row = 1 Or c.Column = 1 Or c(1) = "" Then Exit Sub
If MsgBox("S'ils existent, le commentaire et le fichier de l'image seront supprimés." _
   & vbLf & "Voulez vous continuer ?", 4, "Cellule " & c(1).Address(0, 0)) = 7 Then Exit Sub
Dim chemin$, nomA$
Cancel = True
chemin = ActiveWorkbook.Path & "\Photos acteurs\"
nomA = chemin & c(1, 3 - c.Column) & IIf(c.Column > 2, " " & c(1), "")
c(1).ClearComments
On Error Resume Next
Kill nomA & ".png"
Kill nomA & ".jpg"
End Sub

Fichier (4).

A+

 

[maval]

Re : Image au survol d'une cellule

Re,

Je vous remercie beaucoup de votre aide mais je ne comprend pas. Ma demande était de survoler une cellule pour afficher une image correspondant au nom qui se trouve dans la cellule mais peut-être que je ne comprend pas votre démarche qui est surement très bonne depuis le temps que vous m'aider je commence a vous connaître . Pouvez vous m'expliquez parce que je n'arrive pas a faire fonctionner.
Je vous remercie infiniment de votre aide très professionnelle.

Bonne journée

 

[job75]

Re : Image au survol d'une cellule

Re,

je ne comprend pas. Ma demande était de survoler une cellule pour afficher une image (...)

Faudrait suivre et tester maval, pour qu'une image s'affiche il faut d'abord l'avoir créée !!!

Comme Modeste geedee l'a bien dit, l'image est mise dans un commentaire.

PS : je viens de modifier au post #13 le message du clic droit.

A+