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.
- Messages
- 308
- Excel
- 2016
- Inscrit
- 15/06/2017
- Emploi
- Bénéficiaire de la sécurité de la vieillesse
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
- Messages
- 308
- Excel
- 2016
- Inscrit
- 15/06/2017
- Emploi
- Bénéficiaire de la sécurité de la vieillesse
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.
- Messages
- 308
- Excel
- 2016
- Inscrit
- 15/06/2017
- Emploi
- Bénéficiaire de la sécurité de la vieillesse
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