XL 2010 [RÉSOLUE]Centrer une image dans une cellule

Toubabou · 8 Mai 2019

Bonjour à tous,
LE code suivant permets d'envoyer plusieurs informations sur une page d'impression, "Image3" en autre. Pourriez-vous m'aider afin que cette "Image3" centre l'image dans le haut de sa cellule de destination, soit la cellule" B4"

VB:

Private Sub CommandButton5_Click()    'Envoi feuille Impression
    Dim S As Shape, Tablo, I&
    Application.ScreenUpdating = False
    Sheets("IMPRESSION").Visible = 1
    Sheets("IMPRESSION").Select
    For Each S In ActiveSheet.Shapes
        If Not Intersect(S.TopLeftCell, [A1:B4]) Is Nothing Then S.Delete
    Next
    [b16:B400].ClearContents
      
         [a5] = Label13: [b5] = Label7
         [a7] = Label5: [b7] = Label8
         [a9] = Label6: [b9] = Label10
         [a11] = Label11: [b11] = Label9
         [a13] = Label12: [a15] = Label3
         [B15] = Label4:
        
    [A1] = ComboBox1: [b1] = ComboBox2
    [A6] = Textbox2: [B6] = Textbox4
    [A8] = Textbox1: [B8] = Textbox5
    [A10] = Textbox3: [B10] = TextBox8
    [A12] = TextBox9: [B12] = TextBox11
    [A14] = TextBox10: [A16] = TextBox6
    Tablo = Split(TextBox7.Text, Chr(10))
    For I = LBound(Tablo) To UBound(Tablo)
        Cells(I + 16, 2) = Trim(Replace(Tablo(I), Chr(10), ""))
    Next I
    Rows("16:400").EntireRow.AutoFit
    Call InsImage(Image1.Tag, [A4], 1)
    Call InsImage(Image2.Tag, [B4], 2)

    If Image3.Tag = "" Then OptionButton5 = True    'lance OptionButton_Click
    Call InsImage(Image3.Tag, [B4], 3)
    'If CheckBox1.Value = True Then
    '   ActiveSheet.Shapes("Image3").Visible = True
    'Else
    '   ActiveSheet.Shapes("Image3").Visible = False
    'End If
    Application.Goto [A1], True
    '  [A1].Activate
    Unload Me
End Sub

Merci par avance,
Toubabou

Staple1600 · 8 Mai 2019

Bonsoir le fil

Toubabou
1) Il manque la macro InsImage
2) Depuis le temps (4/12/2014) , tu devrais savoir que c'est plus simple quand le demandeur joint un fichier exemple

Toubabou · 8 Mai 2019

Staple1600 à dit:
Bonsoir le fil

Toubabou
1) Il manque la macro InsImage
2) Depuis le temps (4/12/2014) , tu devrais savoir que c'est plus simple quand le demandeur joint un fichier exemple

Je le sais bien mais mon fichier est très lourd

Staple1600 · 8 Mai 2019

Re

On ne joint jamais le fichier original, mais une copie simplifiée illustrant le problème
Du coup, j'ai pondu ceci (sans ton fichier)
Donc je publie et te laisse faire les adaptations nécessaires

VB:

Private Sub Ajuster_SHP(rng As Range, shpNom$)
Dim shp As Shape: Set shp = ActiveSheet.Shapes(shpNom)
With shp
.Top = rng.Top: .Left = rng.Left
.Width = rng.Width: .Height = rng.Height
End With
End Sub

Sub test()
Ajuster_SHP Range("B4"), "TOTO"
End Sub

Ici dans cet exemple, j'utilise une forme* nommée TOTO
(*: shape)

Toubabou · 8 Mai 2019

Staple1600 à dit:
Re

On ne joint jamais le fichier original, mais une copie simplifiée illustrant le problème
Du coup, j'ai pondu ceci (sans ton fichier)
Donc je publie et te laisse faire les adaptations nécessaires

VB:

Private Sub Ajuster_SHP(rng As Range, shpNom$) Dim shp As Shape: Set shp = ActiveSheet.Shapes(shpNom) With shp .Top = rng.Top: .Left = rng.Left .Width = rng.Width: .Height = rng.Height End With End Sub Sub test() Ajuster_SHP Range("B4"), "TOTO" End Sub

Ici dans cet exemple, j'utilise une forme* nommée TOTO
(*: shape)

Merci beaucoup, si j'ai bien compris, je doit remplacé "TOTO" par "Image3"?

Staple1600 · 8 Mai 2019

Re

Bah, tu le sauras en faisant l'essai, non?

Toubabou · 8 Mai 2019

Hi oui effectivement. alors après un premier essai toujours pas centrée.

Staple1600 · 8 Mai 2019

Re

Avec celle-ci?
Cette-fois-ci la macro centre la première "shape" sur la feuille active

VB:

Sub Test2()
Centrer_SHP ActiveSheet.Shapes(1), Range("B4")
End Sub

Private Sub Centrer_SHP(Shp As Shape, r As Range)
With Shp
.Left = r.Left + ((r.Width - .Width) / 2)
.Top = r.Top + ((r.Height - .Height) / 2)
End With
End Sub

Toubabou · 8 Mai 2019

Staple1600 à dit:
Re

Avec celle-ci?
Cette-fois-ci la macro centre la première "shape" sur la feuille active

VB:

Sub Test2() Centrer_SHP ActiveSheet.Shapes(1), Range("B4") End Sub Private Sub Centrer_SHP(Shp As Shape, r As Range) With Shp .Left = r.Left + ((r.Width - .Width) / 2) .Top = r.Top + ((r.Height - .Height) / 2) End With End Sub

Toujours pas, mais j'avoue que je ne suis toujours pas doué en VBA
Jean-Marie M

Staple1600 · 8 Mai 2019

Re

Chez moi, cela fonctionne
Sur ma feuille active, j'ai deux formes (Shape) et une image (Picture)
Donc si je lance les deux macros l'une après l'autre, l'image s'adapte à la taille de la cellule puis se centre en D9

VB:

Sub Test3()
Ajuster_SHP Range("D9"), "Image 3"
Centrer_SHP ActiveSheet.Shapes(3), Range("D9")
End Sub
Private Sub Ajuster_SHP(rng As Range, shpNom$)
Dim Shp As Shape: Set Shp = ActiveSheet.Shapes(shpNom)
With Shp
.Top = rng.Top: .Left = rng.Left
.Width = rng.Width: .Height = rng.Height
End With
End Sub
Private Sub Centrer_SHP(Shp As Shape, r As Range)
With Shp
.Left = r.Left + ((r.Width - .Width) / 2)
.Top = r.Top + ((r.Height - .Height) / 2)
End With
End Sub

Voir copie d'écran ci-dessous

Toubabou · 8 Mai 2019

Staple1600 à dit:
Re

Chez moi, cela fonctionne
Sur ma feuille active, j'ai deux formes (Shape) et une image (Picture)
Donc si je lance les deux macros l'une après l'autre, l'image s'adapte à la taille de la cellule puis se centre en D9

VB:

Sub Test3() Ajuster_SHP Range("D9"), "Image 3" Centrer_SHP ActiveSheet.Shapes(3), Range("D9") End Sub Private Sub Ajuster_SHP(rng As Range, shpNom$) Dim Shp As Shape: Set Shp = ActiveSheet.Shapes(shpNom) With Shp .Top = rng.Top: .Left = rng.Left .Width = rng.Width: .Height = rng.Height End With End Sub Private Sub Centrer_SHP(Shp As Shape, r As Range) With Shp .Left = r.Left + ((r.Width - .Width) / 2) .Top = r.Top + ((r.Height - .Height) / 2) End With End Sub

Voir copie d'écran ci-dessous
Regarde la pièce jointe 1030279

Désolé JM, cela ne fonctionne pas dans mon fichier, ce n'est pas grave et je suis convaincu que c'est moi qui n'est résolument pas doué.
Je te prie de bien vouloir m'excuser de t'avoir pris du temps inutilement. Merci tout de même.
Jean-Marie M...

Staple1600 · 8 Mai 2019

Re

NB: Je suis connecté sur XLD de mon plein gré.
Et si je te réponds c'est que je suis disponible

Essaies sur un classeur vierge (comme sur mon exemple, deux formes automatiques et une image nommé Image 3)
Normalement tu dois obtenir le même résultat.

Sinon d'autres viendront t'aider

Pour le moment, je m'en vais regarder Pandorum.

Je repasserai plus tard.

Staple1600 · 8 Mai 2019

Re,

Donc j'ai ouvert ton fichier
(que tu devrais anonymiser cf la photo de l'Userform1 entre autres chose)
Et j'ai bien vu la macro

VB:

Private Sub InsImage(Image$, Cel As Range, ordre As Byte)
    Static Y    'mémorise
    Cel.Activate
    Cel = Image
    With Sheets("IMPRESSION").Pictures.Insert(Image)
        '.Name = Image
        .ShapeRange.LockAspectRatio = msoTrue
        If ordre = 1 Then
            .Height = Cel.Height * 0.9
            If .Width > Cel.Width * 0.9 Then .Width = Cel.Width * 0.9
            .Top = Cel.Top + ((Cel.Height - .Height) / 2)
            .Left = Cel.Left + ((Cel.Width - .Width) / 2)
            Y = .Top
            ElseIf ordre = 2 Then
            .Top = Y + 120
            .Left = Cel.Left + ((Cel.Width - .Width) / 2)
            
        ElseIf ordre = 3 Then
            .Top = Y
            .Left = Cel.Left + ((Cel.Width - .Width) / 2)
            .Height = 100
        Else
            .Top = Y + 120
        End If
    End With
End Sub

Maintenant, pourquoi ne pas avoir laissé le commentaire lors de ton copier/coller dans le fil?
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''Macro faite par JOB75 le 02/10/2018, affiche automatiuement l'image de OptionButton4 en cas de non sélection d'un OptionButton''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Je laisse donc la main à job75 si il repasse par ici

Et je retourne voir mon film

Toubabou · 9 Mai 2019

Staple1600 à dit:
Re,

Donc j'ai ouvert ton fichier
(que tu devrais anonymiser cf la photo de l'Userform1 entre autres chose)
Et j'ai bien vu la macro

VB:

Private Sub InsImage(Image$, Cel As Range, ordre As Byte) Static Y 'mémorise Cel.Activate Cel = Image With Sheets("IMPRESSION").Pictures.Insert(Image) '.Name = Image .ShapeRange.LockAspectRatio = msoTrue If ordre = 1 Then .Height = Cel.Height * 0.9 If .Width > Cel.Width * 0.9 Then .Width = Cel.Width * 0.9 .Top = Cel.Top + ((Cel.Height - .Height) / 2) .Left = Cel.Left + ((Cel.Width - .Width) / 2) Y = .Top ElseIf ordre = 2 Then .Top = Y + 120 .Left = Cel.Left + ((Cel.Width - .Width) / 2) ElseIf ordre = 3 Then .Top = Y .Left = Cel.Left + ((Cel.Width - .Width) / 2) .Height = 100 Else .Top = Y + 120 End If End With End Sub

Maintenant, pourquoi ne pas avoir laissé le commentaire lors de ton copier/coller dans le fil?
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''Macro faite par JOB75 le 02/10/2018, affiche automatiuement l'image de OptionButton4 en cas de non sélection d'un OptionButton''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Je laisse donc la main à job75 si il repasse par ici

Et je retourne voir mon film

Je n'ai pas laissé le commentaire parce-que je pensais que c'était personnel. Je m'excuse si j'ai froissé quelqu'un, surtout JOB75, ce n'étais pas mon intention.
Jean-Marie

Staple1600 · 9 Mai 2019

Bonsoir le fil

Aie, petit quiproquo détécté
Donc je passe en Option Explicit pour le lever illico presto.
Je voulais juste dire qu'en laissant le commentaire indiquant l'auteur du code, ou en indiquant dans ton 1er message, un truc du genre
"J'ai un souci avec cette macro de Job75 que je n'arrive pas à adapter"
Bah, en lisant ton message avec cette info en plus, on se dit qu'il y a de fortes chances que lisant cela Job75 viendra te filer un coup de main.

Donc nulle froissement dans ta discussion, et désolé pour le quiproquo.

XL 2010 [RÉSOLUE]Centrer une image dans une cellule

Toubabou

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

Toubabou

XLDnaute Impliqué

Pièces jointes

Staple1600

XLDnaute Barbatruc

Toubabou

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

Toubabou

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

Toubabou

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

Toubabou

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Toubabou

XLDnaute Impliqué

Staple1600

XLDnaute Barbatruc

Discussions similaires