XL 2013 Centrer une image (.jpg ou .png) verticalement et horizontalement dans une cellule excel.

[ludolmrb]

Bonjour à Tous.

Je travaille actuellement sur un projet sur excel 2013 pour la mise en ligne d'une liste d'engagés pour épreuve sportive avec les images des marques motos.
J'ai réussi à faire en sorte d'automatiser l'insertion des images en fonction de chaque pilote mais je n'arrive pas à centrer les images à l'intérieur des cellules.

Pour info, les images sont recherchées dans un dossier sur mon ordi et placées avec ce code que j'ai trouvé et qui fonctionne à merveille:

Sub AffImage()
' Sélectionner les cellules contenant un lien vers une image et appeler la macro
' AffImage les affichera sur le lien ou dans la colonne de gauche ou de droite
Const hDefaut = 75 ' hauteur des images
Const imgDefaut = "" ' saisir chemin complet et le nom de l'image par défaut à afficher si erreur
Dim msg As String, r As Long, h As Long, lmax As Long
Dim c As Range, numfich As Integer
Dim fich
msg = "Oui : Afficher les images à gauche des liens sélectionnés" & vbCrLf
msg = msg & "Non : Afficher les images sur les liens sélectionnés" & vbCrLf
msg = msg & "Annuler : Afficher les images à droite des liens sélectionnés"
r = MsgBox(msg, vbYesNoCancel, "Cellules où mettre les images")
If r = vbYes Then
r = -3
ElseIf r = vbNo Then
r = 0
Else
r = 1
End If
h = InputBox("Hauteur des lignes :", "Choix hauteur", hDefaut)
For Each c In Selection
'c.ColumnWidth = 10
fich = c.Value
' test fichier
If fich <> "" Then
If Left(fich, 7) = "http://" Then
' on conserve le lien sur le net
Else
numfich = FreeFile()
On Error GoTo errfich
Open fich For Input As #numfich
Close #numfich
On Error GoTo 0
End If
End If
'
If fich <> "" Then
c.RowHeight = h 'fixer la hauteur de ligne
ActiveSheet.Pictures.Insert(fich).Select 'ouverture image
With Selection.ShapeRange
.LockAspectRatio = msoTrue 'conserver les proportions
.Height = h - 4 'hauteur de l'image = hauteur des lignes - 4
.Left = c.Offset(0, r).Left + 2 'à gauche colonne A (sinon tu calcules avec la largeur de colonne)
.Top = c.Top + 2 'et positionner verticalement
End With
End If
Next c
Exit Sub
errfich:
fich = imgDefaut
Resume Next
End Sub

Les images sont placées dans les cellules mais non centrées à l'horizontale ni à la verticale.
Soit on modifie le code pour les centrer soit je refais un bouton avec un code vba mais je ne suis pas doué.

Merci à tous par avance

Cordialement

Ludo

 

[patricktoulon]

bonjour
sujet vu et revu
voila 1 méthode représentée en sheet1 et sheet2 l'une indirecte(calcul) l'autre en touchant directement l'image
j'y ai ajouté la réduction de poids de l'mage les kilos ca grimpe vite

 

[ludolmrb]

Bonjour

Merci pour cette explication.

En fait j'ai déjà une macro qui me place mes images en fonction de mes paramètres définis.
Mais ces images ne se centrent pas dans les cellules.
Je souhaiterais une macro qui, quand je sélectionne une plage de cellule et donc les images à l'intérieur de ces cellules, puisse me centrer ces images .
Ou bien modifier la macro de départ pour centrer ces images.

Dans l'attente, merci beaucoup à tous

 

[patricktoulon]

re
exemple

Sub test()
    centreAllImageonPlage Sheets(1).Range("A1:d6")
End Sub


Sub centreAllImageonPlage(plage)
    Dim pict As Shape, cel As Range
    For Each pict In plage.Parent.Shapes
        Set cel = pict.TopLeftCell
        If Not Intersect(cel, plage) Is Nothing Then
            pict.Left = cel.Left + ((cel.Width - pict.Width) / 2)
            pict.Top = cel.Top + ((cel.Height - pict.Height) / 2)
        End If
    Next
End Sub

 

[ludolmrb]

Re

Merci pour le code

J'ai changé la plage ou se trouve mes images, mais en activant la macro rien ne se passe....

Je joins mon fichier excel ainsi que les images servant à alimenter les tableaux au cas ou si vous pouviez éclaircir cette difficulté

 

[patricktoulon]

re
ben regarde tes lien d'image tantôt en minuscule tantôt en majuscule
et l'image yamaha elle est ou tu a envoyé yam
bref fais un peu attention a ce que tu fais
perso j'ai pas envie de me taper les linck car chez moi "user\ludo" n'existe pas
je t'ai donné un code qui a été testé et fonctionne
si ça fonctionne pas chez toi et vu la simplicité du code et de son raisonnement ,c'est que tu a fait une erreur quelque part ce qui m’étonnerait pas vu les liens de fichiers différents pour une même image

 

[ludolmrb]

Re

Mon problème n'amenait pas à facheries....

Simplement tous les liens sont là pour rappeler chaque image pour chaque pilote, et le lien en rouge permet de définir le dossier ou seront placées les images, ce qui changera en même temps tous les autres liens. J'ai plusieurs noms de marque car quand les pilotes s'engagent soit ils utilisent des abréviations (yam) ou le nom complet (yamaha) donc obligé d'utiliser tous ces noms. (je n'ai pas mis toutes les images sinon tu en aurais eu 40)

Simplement quand j'utilise le code, rien ne ce passe et les images ne bougent pas, faut-il sélectionner en amont la plage avant d'utiliser la macro??

Dans l'attente

 

[patricktoulon]

et oui tu la mis ou ce code ?
tu veux que cela soit exécuté quand?

 

[ludolmrb]

Re

le code je l'ai mis avec le bouton 'Centrer Image' et pouvoir l'utiliser a chaque lise a jour de ma liste....

 

[patricktoulon]

je te la fait courte
cela dit il manque la suppression avant donc a faire sinon tu va avoir des image en double

Sub AffImage()
    ' Sélectionner les cellules contenant un lien vers une image et appeler la macro
    ' AffImage les affichera sur le lien ou dans la colonne de gauche ou de droite
    Const hDefaut = 75 ' hauteur des images
    Const imgDefaut = "" ' saisir chemin complet et le nom de l'image par défaut à afficher si erreur
    Dim msg As String, r As Long, h As Long, lmax As Long
    Dim c As Range, numfich As Integer
    Dim fich
    msg = "Oui : Afficher les images à gauche des liens sélectionnés" & vbCrLf
    msg = msg & "Non : Afficher les images sur les liens sélectionnés" & vbCrLf
    msg = msg & "Annuler : Afficher les images à droite des liens sélectionnés"
    r = MsgBox(msg, vbYesNoCancel, "Cellules où mettre les images")
    If r = vbYes Then
        r = -3
    ElseIf r = vbNo Then
        r = 0
    Else
        r = 1
    End If
    h = InputBox("Hauteur des lignes :", "Choix hauteur", hDefaut)
    For Each c In Selection
        'c.ColumnWidth = 10
        fich = c.Value
        ' test fichier
        If fich <> "" Then
            If Left(fich, 7) = "http://" Then
                ' on conserve le lien sur le net
            Else
                numfich = FreeFile()
                On Error GoTo errfich
                Open fich For Input As #numfich
                Close #numfich
                On Error GoTo 0
            End If
        End If
            '
        If fich <> "" Then
            c.RowHeight = h 'fixer la hauteur de ligne
            ActiveSheet.Pictures.Insert(fich).Select 'ouverture image
            With Selection.ShapeRange
                .LockAspectRatio = msoTrue 'conserver les proportions
                .Height = h - 4 'hauteur de l'image = hauteur des lignes - 4
                .Left = c.Offset(0, r).Left + 2 'à gauche colonne A (sinon tu calcules avec la largeur de colonne)
                .Top = c.Top + 2 'et positionner verticalement
            End With
        End If
    Next c
    centreAllImageonPlage Sheets("affichage").Range("E2:E200")
    Exit Sub
errfich:
    fich = imgDefaut
    Resume Next
End Sub
Sub centreAllImageonPlage(plage)
    Dim pict As Object, cel As Range
    For Each pict In plage.Parent.Shapes
        Set cel = pict.TopLeftCell
        If Not Intersect(cel, plage) Is Nothing Then
            pict.Left = cel.Left + ((cel.Width - pict.Width) / 2)
            pict.Top = cel.Top + ((cel.Height - pict.Height) / 2)
        End If
    Next
End Sub

 

[ludolmrb]

Pour la suppression des images, j'avais prévu un bouton pour effacer....

Je viens d'essayer et c'est magnifique.... ouah...
Depuis le temps que je cherchait, trop cool

Merci beaucoup

Pour effacer comme je disais plus haut, oui j'avais prévu à chaque mise a jour de supprimer via le bouton pour refaire une nouvelle liste.

En tous cas merci, merci, merci

Crois tu que je peux intégrer la commande effacer avec cette macro???

Dans l'attente