Insérer et redimensionner photo à la taille de la cellule

Bonjour à tous,

Malgré mes recherches, je ne trouve pas de solution à mon besoin.

Je souhaite à partir de référence intégrer automatiquement des photos dans des cellules, et que ces photos se redimensionnent en gardant le ratio.

J'ai réussi à trouver sur me net 2 macros différentes, mais n'arrive pas a les rassembler en une seule qui fonctionne.

Pouvez vous m'aider?

Macro 1 intégration automatique à partir de référence :

Public Sub insere_image()

Const chemin = "C:\Users\X\Desktop\"

On Error Resume Next

For Each o In Selection

o.Activate

Z = o.Offset(0, 1) & ".jpg"

ActiveSheet.Pictures.Insert (chemin & Z)

Next

End Sub

Macro 2 insérer 1 seule photo à partir d'un chemin et redimensionner :

Sub insere_image_ratio()

Dim ficimg As String, Ad As String

Dim MemW As Long, MemH As Long, T As Integer, L As Integer

Dim Lg As Integer, HT As Integer, RatioCell As Single

Dim CellH As Long, CellW As Long, RatioHz As Single, RatioVt As Single

Ad = Selection.Address

CellH = Selection.Height

CellW = Selection.Width

ficimg = Application.GetOpenFilename(".jpg,*.jpg,.gif,*.gif,.jpeg,*.jpeg", , "Choisissez l'image") ' choix nom du fichier

If ficimg = "Faux" Then Exit Sub

ActiveSheet.Pictures.Insert(ficimg).Select ' insertion

With Selection.ShapeRange

MemW = .Width: MemH = .Height

'adapte les ratio

If MemH < CellH And MemW < CellW Then

'l'image < cellule

RatioHz = MemH / CellH

RatioVt = MemW / CellW

If RatioVt < RatioHz Then 'adapter en hauteur

HT = CellH: Lg = MemW * (HT / MemH)

T = 0: L = (CellW - Lg) / 2

Else 'adapter en largeur

Lg = CellW: HT = MemH * (CellW / MemW)

L = 0: T = (CellH - HT) / 2

End If

ElseIf MemH > CellH And MemW > CellW Then

'l'image > cellule

RatioHz = CellH / MemH

RatioVt = CellW / MemW

If RatioVt > RatioHz Then 'adapter en hauteur

HT = CellH: Lg = MemW * (HT / MemH)

T = 0: L = (CellW - Lg) / 2

Else 'adapter en largeur

Lg = CellW: HT = MemH * (Lg / MemW)

L = 0: T = (CellH - HT) / 2

End If

ElseIf MemH > CellH And MemW < CellW Then

'adapter en hauteur

HT = CellH: Lg = MemW * (HT / MemH)

T = 0: L = (CellW - Lg) / 2

ElseIf MemH < CellH And MemW > CellW Then

'adapter en largeur

Lg = CellW: HT = MemH * (Lg / MemW)

L = 0: T = (CellH - HT) / 2

Else

Stop ' pas prévu ?

End If

.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez

.Top = Range(Ad).Top + T ' haut de la cellule

.Left = Range(Ad).Left + L ' gauche de la cellule

.Height = HT

.Width = Lg ' largeur des cellules fusionnées

End With

With Selection

.Placement = xlMoveAndSize

.PrintObject = True

End With

End Sub

Mon but est de rassembler ces 2 macros...

Merci de votre aide.

Bonjour Tazabel24, bonjour le forum,

Ceci sera vraiment utile ...

http://boisgontierjacques.free.fr/pages_site/lesimages.htm

Joseph

Merci beaucoup pour le lien, beaucoup d'infos...

Je regarde si je trouve mon bonheur.

Bonjour,

La macro ci dessous correspondrait à mes attentes, mais elle plante sur la ligne ActiveCell.EntireRow.RowHeight = img.Height + 2

Je ne trouve pas pourquoi.

J'ai également essayé par formule, mais là ça ne fonctionne pas du tout.

Je ne sais plus si j'avais precisé, sur excel 2016.

Merci pour votre aide.

Sub ImportImages()

ActiveSheet.DrawingObjects.Delete

répertoirePhoto = "C:\Users\Xavier\Desktop\"

nf = Dir(répertoirePhoto & "*.jpg") ' premier fichier

Range("b2").Select

Do While nf <> ""

Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & nf)

img.Top = ActiveCell.Top

img.Left = ActiveCell.Left

img.Name = Left(nf, Len(nf) - 4) ' Donne un nom à l'image

ActiveCell.Offset(0, -1) = Application.Proper(Left(nf, Len(nf) - 4))

ActiveCell.EntireRow.RowHeight = img.Height + 2

nf = Dir ' suivant

ActiveCell.Offset(1, 0).Select

Loop

End Sub

Bonjour Tazabel24, bonjour le forum,

Teste ceci ...

Sub ImportImages()

ActiveSheet.DrawingObjects.Delete
répertoirePhoto = "C:\Users\Xavier\Desktop\"
nf = Dir(répertoirePhoto & "*.jpg") ' premier fichier
Range("b2").Select
Do While nf <> ""
    Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & nf)
    img.Top = ActiveCell.Top
    img.Left = ActiveCell.Left
    img.Name = Left(nf, Len(nf) - 4) ' Donne un nom à l'image
    ActiveCell.Offset(0, -1) = Application.Proper(Left(nf, Len(nf) - 4))
    img.Height = ActiveCell.RowHeight - 2  ' s'ajuste à la hauteur de la ligne  (l'un ou l'autre pour garder le ratio)
        ''''img.Width = ActiveCell.ColumnWidth - 2  ' s'ajouste à la largeur de la colonne (l'un ou l'autre)
    nf = Dir ' suivant
    ActiveCell.Offset(1, 0).Select
Loop
End Sub

Si tu exécutes le code plus d'une fois, les copies des images vont s'accumuler l'une par dessus les autres.

Il faudra supprimer les images existantes avant l'insertion.

Différentes méthodes selon le besoin d'une ou d'un lot. http://boisgontierjacques.free.fr/pages_site/lesimages.htm#Suppression

Joseph

Bonsoir,

Nickel, la modification fonctionne...

Merci beaucoup pour l'aide

A bientôt

Bonsoir,

Finalement je n'obtient pas le résultat escompter...

Je dois partir des références dans la colonne A et non pas du répertoire photo complet.

Cette formule trouvé sur le lien me conviendrai, mais elle plante sur la ligne : c.EntireRow.RowHeight = img.Height

Sub ImportImages()

répertoirePhoto = "c:\mesdoc\"

suppression

For Each c In [A2:A6]

nf = répertoirePhoto & c & ".jpg"

If Dir(nf) <> "" Then

Set img = ActiveSheet.Pictures.Insert(nf)

img.Left = c.Offset(, 1).Left

img.Top = c.Offset(, 1).Top

c.EntireRow.RowHeight = img.Height

End If

Next

End Sub

Sub suppression()

For Each i In ActiveSheet.Shapes

If i.Type = 13 Then i.Delete

Next i

End Sub

Je souhaiterai que la photo s'adapte à la hauteur et largeur de la cellule en gardant les proportions d'origine pour ne pas la déformer.

Si quelqu'un peu m'aider, merci par avance.

Bonjour Tazabel24, bonjour le forum,

Si j'ai bien compris ta demande... on nomme l'objet et ensuite, on mentionne ce qu'on veut lui faire.

Au lieu de :

c.EntireRow.RowHeight = img.Height

... on veut que la hauteur de l'image = une valeur quelconque

Il faut écrire :

img.Height = c.RowHeight

Joseph

Rechercher des sujets similaires à "inserer redimensionner photo taille"