Afficher une image au survol

tactic6

XLDnaute Impliqué
Bonjour le forum et tous les autres

Aujourd'hui j'aimerais un tout autre renseignement
j'aimerais faire afficher une image au survol d'une cellule
ça je sais faire
l'inconvénient c'est que 1 par 1 c'est très long
y aurait un moyen plus rapide de la faire ???
actuellement je fais:
Clic droit sur la cellule => Insérer un commentaire => Clic droit sur la bordure du commentaire => Format de commentaire => Couleur et trait => Motifs et texture => Image => Sélectionner une image
et en fonction du code de l'image je choisi la photo

Mes images sont dans un dossier sur mon DD et ont le nom de la référence

Voici un petit fichier joint pour que vous puissiez mieux comprendre

Merci à tous
 

Pièces jointes

  • Articles.zip
    7 KB · Affichages: 159
  • Articles.zip
    7 KB · Affichages: 164
  • Articles.zip
    7 KB · Affichages: 162

Spitnolan08

XLDnaute Barbatruc
Re : Afficher une image au survol

Bonsoir le fil,

Même si je suis 100% d'accord avec MJ13, l'utilisation de l'enregistreur, dans ce cas, ne va pas permettre une transposition aisée.
Une solution, si bien compris :
Code:
Sub ImageDansCommentaire()
Dim image As String
Dim i As Integer

Application.ScreenUpdating = False
For i = 2 To Range("A2").End(xlDown).Row
    With Sheets("Articles").Cells(i, 1)
        image = "C:\TonChemmin" & Cells(i, 1).Value & ".gif"
        .ClearComments
        .AddComment
        .Comment.Shape.Fill.UserPicture image
        .Comment.Shape.Height = 60
        .Comment.Shape.Width = 60
        .Comment.Visible = False
    End With
Next
End Sub
Ceci étant je t'engage quand même à suivre les conseils de MJ13.

Cordialement
 

tactic6

XLDnaute Impliqué
Re : Afficher une image au survol

Re tout le monde
en effet j'ai essayé avec l'enregistreur mais je n"y suis pas arrivé
quand au code (merci Spitnolan08 ) ça ne fonctionne pas '' le fichier spécifier est introuvable"
à la ligne
.Comment.Shape.Fill.UserPicture image
Une idée??
bon ap bon Week end et merci
 
Dernière édition:

tactic6

XLDnaute Impliqué
Re : Afficher une image au survol

Bonjour le forum et tous les autres
@Spitnolan08
:) oui j'ai bien changé la direction
mes images sont en .jpeg et ont le nom qui est dans les cellules A du genre :
94004541
Dommage qu'on ne puisse pas faire un collage spécial des commentaires

Edit: j'ai aussi essayé avec l'extension .jpeg
 
Dernière édition:

tactic6

XLDnaute Impliqué
Re : Afficher une image au survol

Je vous joins quelques images
merci et bonne journée
 

Pièces jointes

  • Nouveau dossier.zip
    41 KB · Affichages: 158
  • Nouveau dossier.zip
    41 KB · Affichages: 160
  • Nouveau dossier.zip
    41 KB · Affichages: 159

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Afficher une image au survol

Bonjour,



Code:
Sub Trombine()
    repertoire = ThisWorkbook.Path & "\"
    For Each c In Range("A2", [A65000].End(xlUp))
       c.ClearComments
       c.AddComment
       c.Comment.Text Text:=CStr(c)
       fichier = CStr(c.Value) & ".jpg"
       If Dir(repertoire & fichier) <> "" Then
            c.Comment.Shape.Fill.UserPicture repertoire & fichier
            taille = TaillePixelsImage(repertoire, fichier)
            c.Comment.Shape.Height = Val(Split(taille, "x")(1))
            c.Comment.Shape.Width = Val(Split(taille, "x")(0))
            c.Comment.Shape.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
            c.Comment.Shape.ScaleWidth 0.8, msoFalse, msoScaleFromTopLeft
       End If
    Next
End Sub

Function TaillePixelsImage(repertoire, fichier)
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoire)
  Set myFile = myFolder.Items.Item(fichier)
  TaillePixelsImage = myFolder.GetDetailsOf(myFile, 26)
End Function

JB
 

Pièces jointes

  • SurvolArticles2.zip
    41.3 KB · Affichages: 276
Dernière édition:

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Afficher une image au survol

Bonjour,

Dans l'exemple, les photos sont dans le même répertoire que le fichier XLS

repertoire = ThisWorkbook.Path & "\"

Il faut mettre le nom du répertoire:

repertoire="c:\xxxx\"


JB
 

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Afficher une image au survol

Essayer avec ce code. Si le fichier jpg n'est pas trouvé, un message est affiché:


Code:
Sub Trombine()
    repertoire = ThisWorkbook.Path & "\"
    For Each c In Range("A2", [A65000].End(xlUp))
       c.ClearComments
       c.AddComment
       c.Comment.Text Text:=CStr(c)
       fichier = CStr(c.Value) & ".jpg"
       If Dir(repertoire & fichier) <> "" Then
            c.Comment.Shape.Fill.UserPicture repertoire & fichier
            taille = TaillePixelsImage(repertoire, fichier)
            c.Comment.Shape.Height = Val(Split(taille, "x")(1))
            c.Comment.Shape.Width = Val(Split(taille, "x")(0))
            c.Comment.Shape.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
            c.Comment.Shape.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
       Else
         MsgBox fichier & " non trouvé"
       End If
    Next
End Sub

Function TaillePixelsImage(repertoire, fichier)
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoire)
  Set myFile = myFolder.Items.Item(fichier)
  TaillePixelsImage = myFolder.GetDetailsOf(myFile, 26)
End Function

JB
 

tactic6

XLDnaute Impliqué
Re : Afficher une image au survol

c'est bien ce que je pensais c'est la première chose que j'ai recherché et pourtant même en le déplaçant dans le dossier de ton code et en laissant le chemin d'origine ça me fait pareil
en plus j'ai plus de 3000 images et je doit "tuer" la tache excel pour arrêter sinon je clic encore ok après demain
incroyable
 

Discussions similaires

Statistiques des forums

Discussions
312 841
Messages
2 092 703
Membres
105 514
dernier inscrit
Hébera