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 · 2 Août 2016

Bonjour DOMIMARE,

Avec le classeur se serait plu facile de tester et visualiser le souci.

Par ailleurs,

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.

pour adapter la taille de l'image à une cellule et respecter les proportions de l'image, il ne faut spécifier que sa hauteur (celle de la cellule) , .Shapes(Nom).LockAspectRatio = msoTrue se chargeant d'établir sa largeur.

Donc, supprimer la ligne : .Shapes(Nom).Width = Cell.Width

A+

DOMIMARE · 3 Août 2016

Bonjour et merci de votre aide.
0 partir de ce que vous m'avez dit et en me renseignant un peu sur le positionnement des Shapes j'ai transformé ainsi 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
Next
End With
End Sub
***********************************************
Il y a encore un pbm pour le positionnement des images:
leurs proportions est respectée mais elles débordent de la cellule par le bas
Outre ce pbm:
Si je sélectionne une cellule et que je lance la macro elle place deux images!!
J'essaie de joindre la feuille en question
Merci beaucoup de votre aide
DOMIMARE

DOMIMARE · 3 Août 2016

Precision: l'image déborde aussi sur la doite; elle est insérée 2 fois (la même image) une fois proportionnée et la deuxième fois déformée
Merci
Domimare

Paf · 3 Août 2016

Re,

Pas réussi à mettre en évidence les soucis suivants:

Il y a encore un pbm pour le positionnement des images:elles débordent de la cellule par le bas

la macro place deux images!!

l'image déborde aussi sur la doite

Le code tel qu'il est écrit ne peut pas placer deux images dans la même cellule. L'image insérée est proportionnée suivant la hauteur de la cellule.

Soit il existe déjà une image dans la cellule (peu probable)
Soit le code fourni n'est pas réellement celui qui tourne
Soit il y a d'autres macros qui se déclenchent au lancement de la macro versComm()

sinon il faudrait expliquer la manipulation effectuée avant de lancer la macro.

A+

PS: y a t il d'autres classeurs ouverts lors de l'exécution de la macro ?

Paf · 3 Août 2016

re,

que l'image déborde sur la droite, est un souci de largeur de l'image par rapport à sa hauteur .

si l'image d'origine fait 20 de haut pour 60 de large . si la cellule fait 2 de haut pour 5 de large, lors de la transformation de l'image, celle ci mesurera 2 de haut pour 6 de large , donc débordera.

Le problème sera le même si l'on force la largeur de l'image par rapport à la largeur de la cellule, il peut arriver que l'image déborde sous la cellule.

Pour pallier cet 'inconvénient' il faudrait rajouter un test pour savoir quelle dimension on fige.

Mais a priori ce n'est pas le souci majeur.

A+

Paf · 3 Août 2016

Re,re,

S'il y a déjà des images dans les cellules sélectionnées, les images s'affichent sans être redimensionnées en haut à gauche de la plage sélectionnée.
Par ailleurs, il y a plus de 750 images 'parasites' dans le classeur fourni.
J'y travaille.
A+

Paf · 3 Août 2016

Re,

aménagement du code pour:
-supprimer les commentaires et les images existants dans la sélection ( ce qui provoquait des anomalies)
- ajouter l'adresse de la cellule dans le nom de l' image à insérer pour éviter la confusion de nom si plusieurs cellules de la sélection ont la même valeur (ce qui générait plusieurs images du même nom)

VB:

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
repertoirePhoto = "C:\Documents and Settings\Chef\Bureau\Test Excel\"   ' Adapter
With Worksheets("mots")

'Suppression  images et commentaires existants dans la sélection
For Each Cell In Selection
    If Not Cell.Comment Is Nothing Then Cell.Comment.Delete
    For Each Sh In .Shapes
        If Sh.TopLeftCell.Address = Cell.Address Then Sh.Delete
    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 la cellule dans l'objet commentaire
    Nom1 = Cell.Text
    Nom2 = Cell.Text & Cell.Address(0, 0) ' ajout de l'adresse au nom de l'image pour éviter les quiproquo
    If Dir(repertoirePhoto & Nom1 & ".jpg") = Nom1 & ".jpg" Then
        .Pictures.Insert(repertoirePhoto & Nom1 & ".jpg").Name = Nom2
        .Shapes(Nom2).Left = Cell.Left
        .Shapes(Nom2).Top = Cell.Top
        .Shapes(Nom2).LockAspectRatio = msoTrue
        .Shapes(Nom2).Height = Cell.Height
    End If
 
    ' supprimée.Shapes(Nom).Width = Cell.Width
  'Cell.Value = ""  ' à activer au besoin pour vider la cellule

Next
End With
End Sub

reste plus que le débordement à droite à régler

A+

DOMIMARE · 3 Août 2016

Bonjour,
Merci de me consacrer du temps. Je débute. Comment "voyez-vous " les 750 images parasites. Après chaque essai j'efface les images (une par une) et les commentaires. Est ce quje la macro marche correctement chez vous (bien sûr avec d'autres images et d'autres noms).
Bonne journée
DOMIMARE

Paf · 3 Août 2016

re,

j' ai rencontré les m^mes soucis que vous et ils sont corrigés dans le code proposé au post 9.
Il me reste encore un gros soucis de plantage d'excel !!!

Pour visualiser les images une solution :

Code:

Sub ImagesFantome()
MsgBox ActiveSheet.Shapes.Count
For Each Img In ActiveSheet.Shapes
  MsgBox Img.Name & " " & " Type : " & Img.Type & " " & "At : " & Img.TopLeftCell.Address
  'Img.Delete
Next
End If
End Sub

le type est 4 pour Commentaire, 13 pour Image, 11 pour Image liée.

pour supprimer, mettre la ligneMsgBox ... en commentaire et activer la ligne Img.Delete

A+

Edit : curieusement, s'il s'agit de commentaire, l'adresse affichée est décalée (-1,1) par rapport à l'adresse réelle soit :B2 au lieu de A3

Paf · 3 Août 2016

re,

une version qui fonctionne sur mon jeu d'essai. à tester:

VB:

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  <==
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
        .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
    End If
   
    ' supprimée.Shapes(Nom).Width = Cell.Width
  'Cell.Value = ""  ' à activer au besoin pour vider la cellule
  Next
End With
End Sub

A+

DOMIMARE · 3 Août 2016

Bonsoir,
Avec ce dernier code les commentaires sont insérés mais pas les images
???

Staple1600 · 3 Août 2016

Bonsoir à tous

DOMIMARE

Code:

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

Tu as adapté le chemin dans ton code?

EDITION: Bonsoir Paf

Paf · 3 Août 2016

Re,

curieux ! pas de soucis chez moi.

Votre répertoire est-il correcte ?

essayez d'ajouter, après If Dir(repertoirePhoto & Nom1 & ".jpg") = Nom1 & ".jpg" Then, l'instruction MsgBox Nom1 & ".jpg"
si au lancement de la macro vous n'avez pas de message , il y aura lieu de s'inquiéter .

A+

Edit : bonsoir Staple1600

DOMIMARE · 4 Août 2016

Je n'y comprends plus rien. Vous avez la même version que moi (2010)?
Je suis revenu au code précédent. Si je sélectionne une cellule et que je lance la macro, l'image s'affiche correctement et le commentaire aussi. Je sélectionne une autre cellule je lance la macro. C'est ok... mais au 3 ème essai sur une autre cellule 2 images sont placées (une dans la cellule mais pas proportionnée) l'autre qui déborde.
C'est à devenir fou:
code utilisé:

Code:

' 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
  'Cell.Value = ""  ' à activer au besoin pour vider la cellule
  Next
End With
End Sub

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

Pièces jointes

DOMIMARE

XLDnaute Nouveau

Paf

XLDnaute Barbatruc

Paf

XLDnaute Barbatruc

Paf

XLDnaute Barbatruc

Paf

XLDnaute Barbatruc

DOMIMARE

XLDnaute Nouveau

Paf

XLDnaute Barbatruc

Paf

XLDnaute Barbatruc

DOMIMARE

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Paf

XLDnaute Barbatruc

DOMIMARE

XLDnaute Nouveau

Discussions similaires