XL 2010 Placer automatiquement des images dans des cases portant leur nom en adaptant leurs dimensions

DOMIMARE · 1 Août 2016

Cette macro doit me servir à progresser en paléographie

But : Avoir dans une feuille des images de mots du XVIeme et voir en infobulle son sens (sa transcription) quand on passe le curseur de la souris dessus

Dans un dossier j’ai mis des captures de mots de textes anciens. Ce sont des fichiers jpeg. J’ai mis dans les cases d’une feuille excel les noms de ces fichiers (ex dans une case il y a « sieur » ; dans le dossier des images il y a un fichier « sieur.jpg ».

Je veux deux choses principales :

1) Que la macro affecte un commentaire à la cellule de telle façon qu’en passant le curseur sur la cellule (lorsqu’elle contiendra l’image correspondante) une infobulle m’affiche la transcription (ici : « Sieur » en commentaire.)

2) Qu’elle place correctement l’image dans la cellule (Sieur.jpg dans la cellule qui contient le mot « Sieur » en adaptant l’image aux dimensions de la cellule sans la déformer.

On m’ai dé sur ce forum à faire la macro (on me l’a faite avec beaucoup de gentillesse). Elle crée bien les commentaires de chaque cellule mais elle introduit plusieurs fois les mêmes images (surtout dans les premières cellules à gauche de la zone sélectionnée ; si je sélectionne une zone de 9 cellules, (3X3)elle place 18 images dont 12 dans la première colonne ! et elle ne les dimensionne pas comme souhaitée. Si quelqu’un voit comment résoudre cela, je suis preneur.

Voilà la macro :
' cette macro insère les commentaires et les images (il faut changer le répertoire de celles-ci (adapter)

Sub versComm()

Dim X, Nom, repertoirePhoto As String

Dim Cell As Range

Dim Img As Shape

repertoirePhoto = "C:\Users\Dominique\Pictures\tousles mots\" ' Adapter

On Error Resume Next ' pour évite l'arrêt de la macro si le nom ne correspond pas à une image valide

With ActiveSheet

For Each Cell In Selection

X = Cell.FormulaR1C1 ' place le contenu de la cellule dans la variable X

Cell.AddComment ' ajoute l'objet commentaire

Cell.Comment.Visible = False 'le commentaire sera masqué

Cell.Comment.Text Text:=X 'place le contenu de X dans l'objet commentaire

Nom = X

.Pictures.Insert(repertoirePhoto & Nom & ".jpg").Name = Nom

.Shapes(Nom).Left = Cell.Left

.Shapes(Nom).Top = Cell.Top

.Shapes(Nom).LockAspectRatio = msoTrue

.Shapes(Nom).Height = Cell.Height

.Shapes(Nom).Width = Cell.Width

'Cell.Value = "" ' à activer au besoin pour vider la cellule

Next

End With

End Sub

Paf · 4 Août 2016

Re,

Ma version est XL2003.

En revenant au code initial, il semble normal qu'on retrouve les mêmes soucis.

Pas de réponses à la petite macro du post 10, ni à la question du post 14.

Au post 8 j'ai indiqué une source d'erreur possible (nom d'image en double) et la correction à apporter (incluse dans le code du post 11)

Mais si vous préférez utiliser votre un code qui provoque des anomalies, plutôt que d'essayer de faire fonctionner celui que je vous propose, je ne peux plus rien pour vous.

Bonne suite

DOMIMARE · 5 Août 2016

Je vous prie de m'excuser,
J'ai remis le code qui me semblait approcher de ce que je cherchais car celui du post 11, sur mon pc, ne faisait qu'introduire les commentaires.
Pour le code du post 10 j'ai d'abord eu un message d'erreur (quch comme "End if sans if" j'ai supprimé la ligne "End if" et le "résultat" a été "733" puis un message "Requis(3) Type:11 At:$1$1"
Je suis début et là je ne comprends pas du tout la signification de ce que fait ce code et du résultat...
Si vous avez la patience de continuer sachez que je vous en remercie chaleureusement
Cordialement
DOMIMARE

Paf · 5 Août 2016

Re,

concernant le code du post 10:
-désolé pour l'oubli de suppression du End If
-"résultat" a été "733" indique le nombre d'éléments trouvés dans la feuille ( images, images liées, commentaires)
- "Requis(3) Type:11 At:$1$1" indique le nom de chaque élément trouvé : Requis(3) c'est le nom de l'élément; Type:11 c'est le type de l'élément (cf post 10 pour détail); At:$1$1 donne l'adresse de l'élément dans la feuille ($1$1 parait une curieuse adresse !)

Pour supprimer tous ces éléments:

Code:

Sub ImagesFantome()
MsgBox ActiveSheet.Shapes.Count
For Each Img In ActiveSheet.Shapes
   Img.Delete
Next
End Sub

Avec le code du post 11, si aucune image n'est affichée, c'est qu'il y a un souci dans la lecture des image:

- soit le répertoire n'est pas défini correctement ( cf post 13 et 14) Qu'en est il ?
- soit il n'y a pas d'images correspondant à la cellule dans le répertoire défini. Toutes cellules ont elles une image du même nom dans le répertoire défini ?
- soit le test If Dir(repertoirePhoto & Nom1 & ".jpg") = Nom1 & ".jpg" Then n'est jamais vrai et on effectivement on aura aucune image.

Pour vérifier, insérer cette ligne de code:
MsgBox Dir(repertoirePhoto & Nom1 & ".jpg") & "|" & Nom1 & ".jpg"

juste avant If Dir(repertoirePhoto & Nom1 & ".jpg") = Nom1 & ".jpg" Then

si cela vous indique deux nom identiques, une image doit s'afficher, si les deux noms sont différents, merci de les indiquer en réponse.

un test un peu similaire vous était demandé au post 14. l'avez vous fait, quel en est le résultat ?

Dans l'attente des quatre réponses ....

A+

DOMIMARE · 5 Août 2016

Re bonjour,
Je vais traiter méthodiquement ces questions dans le week-end. Je dois m'absenter cet après midi. Une question "préalable": je ne vois pas d'images dans la feuille (après chaque essai j'ai effacé les images introduites et les commentaires). Que sont ces images "fantômes"? Y a t-il un moyen de les voir et de les effacer en dehors de VBA. Promis je vais faire ce que vous me demandez.
Bon après-midi
DOMIMARE

DOMIMARE · 5 Août 2016

Ne vous enervez pas tout de suite. J'ai tenté quch avant de partir: "f5 + "cellule"+objet et supr". Je vois (avant de faire supr des images en haut de la feuille (sans doute les images fantômes).. La bonne nouvelle c'est qu'en essayant la macro -celle d'origine (gardez votre calme) et en faisant ctrl M cellule par cellule ça marche parfaitement. Si je lance la macro sur une sélection de cellules ça marche aussi sauf si une image est manquante. Dans ce cas il me semble qu'à l'essai suivant l'image n'est plus adaptée à la cellule. PBM une image est traitée comme absente alors qu'elle exite. Je vais voir cela (il s'ait peut-être d'un pbm d'orthographe.
En tout cas je vois que vous aviez bien localisé le pbm et je vais faire les choses que vous m'avez demandées. Je ne comprends pourtant bien ce que sont ces images fantômes.
Merci de votre aide
DOMIMARE

DOMIMARE · 6 Août 2016

Code:

Sub versComm()
Dim Nom1 As String, Nom2 As String, repertoirePhoto As String
Dim Cell As Range, Sh As Shape

repertoirePhoto = "C:\Users\Dominique\Pictures\tousles mots\"      ' Adapter
'On Error Resume Next   ' pour évite l'arrêt de la macro si le nom ne correspond pas à une image valide
With Worksheets("mots") ' à adapter à la feuille  <==
'With ActiveSheet
For Each Cell In Selection
    If Not Cell.Comment Is Nothing Then Cell.Comment.Delete
    For Each Sh In .Shapes
        If Sh.Type = 13 Then
            If Sh.TopLeftCell.Address = Cell.Address Then Sh.Delete
        End If
    Next
Next
  For Each Cell In Selection
    'X = Cell.FormulaR1C1          ' place le contenu de la cellule dans la variable X
   Cell.AddComment               ' ajoute l'objet commentaire
   Cell.Comment.Visible = False  'le commentaire sera masqué
   Cell.Comment.Text Text:=Cell.Text      'place le contenu de X dans l'objet commentaire
   Nom1 = Cell.Text
    Nom2 = Cell.Text & Cell.Address(0, 0)
  
    If Dir(repertoirePhoto & Nom1 & ".jpg") = Nom1 & ".jpg" Then MsgBox Nom1 & ".jpg"
        .Pictures.Insert(repertoirePhoto & Nom1 & ".jpg").Name = Nom2
        .Shapes(Nom2).Left = Cell.Left
        .Shapes(Nom2).Top = Cell.Top
        tmp = .Shapes(Nom2).Height
        .Shapes(Nom2).LockAspectRatio = msoTrue
        .Shapes(Nom2).Height = Cell.Height
        'si l'image déborde en largeur
       If .Shapes(Nom2).Width > Cell.Width Then .Shapes(Nom2).Width = Cell.Width
 
    ' supprimée.Shapes(Nom).Width = Cell.Width
'Cell.Value = ""  ' à activer au besoin pour vider la cellule
Next
End With
End Sub

Bonjour,
Je viens de prendre le code#11. Seuls les commentaires sont affichés!
Pourtant le répertoire est correctement affiché (j'ai copié la ligne qui marchait dans la précédente macro.
j'avais oublié de supprimer le END IF final
En outre il y avait un message d'erreur à cause de la ligne:
"If Dir(repertoirePhoto & Nom1 & ".jpg") = Nom1 & ".jpg"Then" qu'il fallait compléter par "MsgBox Nom1 & ".jpg""
Et là tout marche.
Voici donc le code qui marche:

DOMIMARE · 6 Août 2016

Votre aide a été précieuse. Je pense que je n'aurai pas pu trouver tout seul la cause de mes pbms que sont les images fantômes.
Il me reste trois questions (si vous avez le temps)
1) Il est plus prudent de commencer par effacer les images fantômes avant de lancer la macro. Puis-je le faire à l'intérieur de "ma macro"?
2) Apres avoir exécuté "imagesFantome" les images et commentaires sont effacés mais il reste les petites flêches rouges de commentaires (il suffit d'enregistrer la feuille edt de la réouvrir pour les faire disparaître). Y a t-il une solution (ce n'est pas un gros pbm)
3) Pour mettre les noms des images dans les cellules j'ai utilisé la fenêtre dos et la commande dir /b > mots.txt
. Le fichier "mots.txt" contient tous les mots du dossier images je n'ai plus qu'à les répmartir sur 7 colonnes. Cela peut-il assez facilement s'automatiser?
4) Pouvez-vous m'expliquer ce que sont ces images fantômes invisibles au départ.
En tout cas votre patiente m'a permis d'arriver au résultat voulu
Cordialement
DOMIMARE

Paf · 6 Août 2016

Re,

En outre il y avait un message d'erreur à cause de la ligne:
"If Dir(repertoirePhoto & Nom1 & ".jpg") = Nom1 & ".jpg"....

votre correction du code du post 11 me laisse dubitatif quant aux raisons qui empêchait la copie des images et à son désormais fonctionnement .

tel qu'il était dans le post 11, ce test permettait de vérifier si l'image existait dans le répertoire et seulement si ce test était vrai on procédait à la copie de l'image. Quand vous me dites qu'aucune image n'était copiée, c'est que le test n'était jamais vrai !
Pour le vérifier je vous avais demandés un petit aménagement pour afficher le nom de l'image si le test était vrai.

Vous me dites maintenant que tout marche désormais, sans dire si on a bien un message qui s'affiche ; a priori non, ce qui prouverait que le test est toujours faux ( le but de la manip était de déterminer pourquoi !)

votre correction passant outre ce test, car le positionnement de MsgBox ... et la suppression du End If font que le code intermédiaire est toujours exécuté que l'image existe ou non, si une image n'existe pas pour on aura un plantage ( ou bien une image fantôme?)

Le code vous donne satisfaction, c'est le principal !
Mais je ne continuerai pas à supputer des causes de non fonctionnement alors que des réponses claires aux questions posées suffiraient à lever les doutes.

Pour votre nouvelle question, je vous invite à créer une nouvelle discussion.

Bonne suite

XL 2010 Placer automatiquement des images dans des cases portant leur nom en adaptant leurs dimensions

DOMIMARE

XLDnaute Nouveau

Paf

XLDnaute Barbatruc

DOMIMARE

XLDnaute Nouveau

Paf

XLDnaute Barbatruc

DOMIMARE

XLDnaute Nouveau

DOMIMARE

XLDnaute Nouveau

DOMIMARE

XLDnaute Nouveau

DOMIMARE

XLDnaute Nouveau

Paf

XLDnaute Barbatruc

Discussions similaires