Afficher une image au survol

[tactic6]

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

 

[MJ13]

Re : Afficher une image au survol

Bonjour

Tu peux essayer en VBA.

Premièrement essayes déjà avec l'enregistreur de macro.

Puis tu reviens pour nous dire où tu en es.

 

[Spitnolan08]

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 :

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]

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

 

[Spitnolan08]

Re : Afficher une image au survol

Re,

'' le fichier spécifier est introuvable"

Euh........ Tu n'aurais pas oublié de modifier le chemin d'accès au fichier . A moins que ce ne soit le nom du fichier qui ne soit pas bon. Mais là je ne peux rien faire pour toi : on n'a pas accès à tes fichiers images...

Cordialement

 

[tactic6]

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

 

[tactic6]

Re : Afficher une image au survol

Je vous joins quelques images
merci et bonne journée

 

[BOISGONTIER]

Re : Afficher une image au survol

Bonjour,

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

 

[tactic6]

Re : Afficher une image au survol

Re tout le monde
@BOISGONTIER où dois-je donner la direction de mes images ?
merci pour ton aide

 

[BOISGONTIER]

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

 

[tactic6]

Re : Afficher une image au survol

Merci
mais ça ne m'affiche que le code article dans le commentaire
n'y aurait il pas une Référence VBA à cocher ?

 

[BOISGONTIER]

Re : Afficher une image au survol

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

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]

Re : Afficher une image au survol

exact message xxxxxxx.jpg non trouvé idem avec jpeg
bizarre alors qu'avec toi ça marche

 

[BOISGONTIER]

Re : Afficher une image au survol

C'est le répetoire qui ne doit pas être bon.

JB

 

[tactic6]

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