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

Toubabou

XLDnaute Impliqué
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

XLDnaute Barbatruc
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

XLDnaute Impliqué
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

XLDnaute Barbatruc
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

XLDnaute Impliqué
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

XLDnaute Barbatruc
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
01Tobabou.JPG
 

Toubabou

XLDnaute Impliqué
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

XLDnaute Barbatruc
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

XLDnaute Barbatruc
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

XLDnaute Impliqué
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

XLDnaute Barbatruc
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.
 

Discussions similaires

Réponses
7
Affichages
648

Statistiques des forums

Discussions
311 735
Messages
2 082 024
Membres
101 873
dernier inscrit
excellllll