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

T

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
 
Trier par date Trier par votes
Staple1600

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)
 
Vote positif 0 Vote négatif
T

Toubabou

XLDnaute Impliqué
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)
Cliquez pour agrandir...
Merci beaucoup, si j'ai bien compris, je doit remplacé "TOTO" par "Image3"?
 
Vote positif 0 Vote négatif
Staple1600

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
 
Vote positif 0 Vote négatif
T

Toubabou

XLDnaute Impliqué
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
Cliquez pour agrandir...
Toujours pas, mais j'avoue que je ne suis toujours pas doué en VBA
Jean-Marie M
 
Vote positif 0 Vote négatif
Staple1600

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
 
Vote positif 0 Vote négatif
T

Toubabou

XLDnaute Impliqué
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
Cliquez pour agrandir...
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...
 
Vote positif 0 Vote négatif
Staple1600

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.
 
Vote positif 0 Vote négatif
Staple1600

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 ;)
 
Vote positif 0 Vote négatif
T

Toubabou

XLDnaute Impliqué
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 ;)
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
Staple1600

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.
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Question
XL 2019 modifications macro svp
Réponses
3
Affichages
882
Bernard_XLD
Bernard_XLD
V
  • Question
XL 2019 ActiveSheet avec nom feuille contenu dans une cellule
Réponses
3
Affichages
740
Staple1600
Staple1600
Usine à gaz
  • Résolu(e)
Microsoft 365 UserForm - affiche image selon valeur cellules
Réponses
4
Affichages
946
Usine à gaz
Usine à gaz
P
  • Résolu(e)
XL 2019 supprimer la couleur d'une cellule dès que je clique dans une autre cellule
Réponses
2
Affichages
762
pat66
P
L
  • Résolu(e)
Microsoft 365 Coller un code aleatoire dans une cellule sélectionnées au hasard
Réponses
5
Affichages
697
LandryK7
L
C
  • Question
XL 2019 Je rencontre une erreur 9 : "L'indice n'appartient pas à la sélection"
Réponses
3
Affichages
1 K
chris4785478547
C
vincejkt
  • Question
Problème sélection multiple dans listbox
2
Réponses
15
Affichages
4 K
vincejkt
vincejkt
Nicolas JACQUIN
  • Question
XL 2016 Optimisation code agenda
Réponses
0
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
maval
  • Question
XL 2013 Modifier mon code
Réponses
7
Affichages
811
maval
maval
Jgral
  • Résolu(e)
XL 2016 Récupération de Valeur de CheckBox (dans un UserForm) et placement dans une zone de texte
Réponses
2
Affichages
2 K
Jgral
Jgral

Membres actuellement en ligne

13 membres et 88 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 090
Messages
2 116 107
Membres
112 661
dernier inscrit
ceucri