centrer une image dans cellules fusionnées

[B52]

Bonsoir le forum,

Malgrès mes différentes recherches sur le forum, je n'arrive pas à trouver un code qui me permettrait de centrer une image dans une cellule fusionnée.
Mon image garde bien ses proportions mais n'est pas centrée horizontalement et verticalement, elle s'affiche en haut et à gauche.
Par avance merci pour votre aide

voici mon code :
Sub TextBox3_Click()
Dim Emplacement1 As Range
Dim Image1 As Picture

On Error Resume Next
ActiveSheet.Pictures.Delete 'supprimer la dernière photo crée

Set Emplacement1 = Range("A5:C21") 'emplacement des cellules fusionnées ou la photo sera affiché
Emplacement1.Select
Set Image1 = ActiveSheet.Pictures.Insert(Range("A5").Value) 'A5 est la cellule ou est indiqué le chemin de la photo
With Image1.ShapeRange
.Height = Emplacement1.Height
.Width = Emplacement1.Width

End With
End Sub

Bien cordialement
B52

 

[BERRACHED said]

Re : centrer une image dans cellules fusionnées

Salut,B52

As tu essayé

.Height = Range.Height
.Width = Range.Width

Cordialement

 

[B52]

Re : centrer une image dans cellules fusionnées

Salut,B52

As tu essayé

.Height = Range.Height
.Width = Range.Width

Cordialement

Bonjour Said,

J'ai essayé ton code mais cela ne change rien, ce qui semble normal puisque dans mon code, Range est remplacé par Emplacement1.
Mais merci quand même pour ta réponse
Cordialement

 

[Catrice]

Re : centrer une image dans cellules fusionnées

Bonsoir,

Un exemple dans le fichier joint

 

[MuscatMimi]

Re : centrer une image dans cellules fusionnées

pardon erreur de fil,

 

[B52]

Re : centrer une image dans cellules fusionnées

Bonsoir,

Un exemple dans le fichier joint

Bonsoir Catrice,

merci pour ton fichier exemple, ça marche mais dès que j'utilise une photo plus grande que le cadre des cellules fusionnées , cela ne fonctionne plus.
SI tu as d'autres idées, n'hésites pas, merci beaucoup quand même
Cordialement

B52

 

[chris]

Re : centrer une image dans cellules fusionnées

Bonjour

En partant de l'exemple de Catrice

Sub Test()
Set Emplacement1 = Range("C7:E14")
With ActiveSheet.Shapes("Picture 1")
If .Width > Emplacement1.Width Then ratL = .Width / Emplacement1.Width
If .Height > Emplacement1.Height Then ratH = .Height / Emplacement1.Height
rat = Application.Max(ratL, ratH)
If rat <> 0 Then .Width = .Width / rat
.Left = Emplacement1.Left + Emplacement1.Width / 2 - .Width / 2
.Top = Emplacement1.Top + Emplacement1.Height / 2 - .Height / 2
End With
End Sub