Insertion d'une image, maintien des proportions et copie vers une 2nd Feuil (VBA)

[Kahyasse]

Bonjour,

Je suis en train de créer un fichier Excel et pour cela j'ai créer une macro (activé grâce à un bouton) qui me permet d’insérer une image dans une cellule. Dans cette macro j'ai 2 problèmes que je n'arrive pas à résoudre :
-Actuellement je n'ai réussi qu'à insérer l'image, mais celle-ci s'adapte au format de la cellule. Hors je voudrais que l'image s'adapte à la hauteur de la cellule mais non à sa largeur afin de garder les proportionnalités de l'image. De se fait il faudrait que l'image se centre dans la cellule aussi.
-Pour la deuxième partie je voudrais aussi que l'image se copie dans la feuille 2 dans une cellule précise (en sachant que la cellule de départ et la cellule d'arrivée auront le même format). Hors actuellement je n'ai réussi qu'à créer une macro pour copier dans la feuille 2 mais je n'arrive pas à faire que ça soit dans une cellule précise.

Voici la macro que j'ai tenté d'élaborer ainsi que le fichier Excel concerné.

Sub CommandButton_Click()
Dim Image As Variant
Dim L As Single, T As Single, W As Single, H As Single
Worksheets("Feuil1").Range("A1").Select
L = ActiveCell.Left
T = ActiveCell.Top
W = ActiveCell.Width
H = ActiveCell.Height
Image = Application.GetOpenFilename
If Image <> False Then
ActiveSheet.Shapes.AddPicture Image, True, True, L, T, W, H
End If
[A1].Select
Worksheets("Feuil1").Range("A1").CopyPicture
Sheets("Feuil2").Paste
End Sub

Merci d'avance pour votre aide concernant c'est 2 problèmes.

Bien Cordialement

Kahyasse

 

[Compte Supprimé 979]

Re : Insertion d'une image, maintien des proportions et copie vers une 2nd Feuil (VBA

Bonjour

Je ne comprends pas ton problème !?
Si tu augmente la hauteur de ta cellule, l'image prends bien la hauteur ??

Pour la 2ème partie

    Worksheets("Feuil1").Range("A1").CopyPicture    With Sheets("Feuil2")
      .Activate
      .Range("D11").Select
      .Paste
    End With

A+

 

[Kahyasse]

Re : Insertion d'une image, maintien des proportions et copie vers une 2nd Feuil (VBA

Bonjour Bruno M45,

Tout d'abord merci beaucoup pour la seconde partie car cela marche parfaitement comme je le souhaitait.

Pour la première partie, mon problème est que lorsque l'on insère l'image avec ma macro, cette image adapte ses dimensions à la dimension de la cellule. Hors je souhaiterais que l'image s'adapte seulement à la hauteur de la cellule afin de garder les proportionnalités de l'image initiale. Et donc je souhaiterais en plus que l'image se centre horizontalement dans la cellule du coup.

J'espère que j'ai pu être plus clair.

Merci d'avance de ton aide.

Bien cordialement

Kahyasse

 

[BOISGONTIER]

Re : Insertion d'une image, maintien des proportions et copie vers une 2nd Feuil (VBA

Bonjour,

Voir PJ

JB

 

[Kahyasse]

Re : Insertion d'une image, maintien des proportions et copie vers une 2nd Feuil (VBA

Bonjour BOISGONTIER,

Merci pour ta réponse, c'est effectivement tout se qu'il me fallait mais serait il possible de centrer l'image dans la cellule A1.
J'ai essayé en remplaçant : .Shapes(nomImage).Left = c.Left
par .Shapes(nomImage).Left = c.Left + c.Width / 2 - ActiveSheet.Shapes(nomImage).Width / 2
mais sans succès.

Merci d'avance de ton aide.

Kahyasse

 

[BOISGONTIER]

Re : Insertion d'une image, maintien des proportions et copie vers une 2nd Feuil (VBA

Sub ImportImage()
 Image = Application.GetOpenFilename
 If Image <> False Then
   a = Split(Image, "\")
   nomimage = a(UBound(a))
   Set c = Range("A1")
   With ActiveSheet
    .Pictures.Insert(Image).Name = nomimage
    .Shapes(nomimage).Height = c.Height
    .Shapes(nomimage).Left = c.Left + (c.Width - .Shapes(nomimage).Width) / 2
    .Shapes(nomimage).Top = c.Top
    .Shapes(nomimage).LockAspectRatio = msoTrue
  End With
  ActiveSheet.Shapes(nomimage).Copy
  Set f = Sheets("feuil2")
  f.Paste
  f.Shapes(nomimage).Left = f.[D11].Left
  f.Shapes(nomimage).Top = f.[D11].Top
 End If
End Sub

 

[Kahyasse]

Re : Insertion d'une image, maintien des proportions et copie vers une 2nd Feuil (VBA

Merci c'est exactement se qu'il me fallait!

Bon continuation

Kahyasse

 

[aulecomt]

Re : Insertion d'une image, maintien des proportions et copie vers une 2nd Feuil (VBA

Bonjour,

J'ai une soucis pour adapter ma macro avec les conseils de ce post. J'aimerais que l'image qui se place en colonne C soit en proportion et centrer au milieu de la cellule.

Voici la macro que j'utilise :

Sub Affiche_Image_programme_demo()
Dim Ws As Worksheet ' Sert à manipuler plus facilement l'objet feuille
Dim Image As String ' Contiendra le nom de l'image
Dim Lg As Long ' Numéro de la dernière ligne colonne B

Set Ws = Sheets("construction programme") ' Nom de la feuille

Application.ScreenUpdating = False ' Interdit le raffraîchissement d'écran

Efface_Images

With Ws

For Lg = 1 To .Range("B65536").End(xlUp).Row ' Parcourt de toute la colonne B

Image = ThisWorkbook.Path & "\TEST\" & .Cells(Lg, "B") ' Répertoire à actualiser

On Error Resume Next ' On s'affranchit des erreurs
With .Pictures.Insert(Image).ShapeRange ' On insère l'image dont le nom est en colonne B
.LockAspectRatio = msoTrue ' On peut la redimmensionner comme on veut
.Left = Ws.Cells(Lg, "C").Left ' Position gauche
.Top = Ws.Cells(Lg, "C").Top ' Position Haut
.Width = Ws.Cells(Lg, "C").Width ' Largeur
.Height = Ws.Cells(Lg, "C").Height ' hauteur

End With
If Err.Number > 0 Then ' Si une erreur (image non présente)
MsgBox .Cells(Lg, "B") & vbCr & "Image inexistante" ' On le signale
End If
Next Lg
End With
End Sub

Merci d'avance pour vos conseils.

Aulecomt