Aide pour modifier macro qui permet d'afficher des IMAGES (aide sur la taille des ima

[tennis]

Bonjour,

Quelqu'un pourrait il m'aider à modifier cette macro. Actuellement, celle-ci me permet d'afficher dans les cellules de la colonne B les images dont les noms figurent dans la colonne A. Ces images se doivent d'être contenues dans le même répertoire que le fichier excel.

J'aimerais simplement la modifier et faire que les images s'affichent au format de la cellule B en gardant les proportions. C'est au maximum la largeur de la cellule et au maximum la hauteur de la cellule. Mais je me repete les proportions se doivent d'être respectées.

Voici la macro actuelle :



Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Val As String
Dim MyCell As Range
Dim MyPicture As Picture
Dim Pict
Dim a As Long
On Error GoTo errorhandler
Application.ScreenUpdating = False

Val = Target.Value

With Application.FileSearch
.NewSearch
.Filename = ".jpg"
.LookIn = ThisWorkbook.Path
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending

If .Execute > 0 Then
Set MyCell = Target.Offset(0, 1)
MyCell.Select



For Each Pict In ActiveSheet.DrawingObjects ' supprimer ancienne image dans cellule
If Pict.Left = MyCell.Left + (MyCell.Width - 50) / 2 And Pict.Top = MyCell.Top + (MyCell.Height - 50) / 2 Then Pict.Delete
Next

Set MyPicture = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Val & ".jpg")
With MyPicture.ShapeRange
'.LockAspectRatio = msoFalse
.Height = 55
'.Width = 55
.Top = MyCell.Top + (MyCell.Height - 50) / 2
.Left = MyCell.Left + (MyCell.Width - 50) / 2

End With
MyCell.Select
MsgBox Pict.Left
End If


End With
Application.ScreenUpdating = True
Exit Sub

errorhandler:
Application.ScreenUpdating = True
Exit Sub
End Sub

[Hasco]

Avec ceci ça fonctionne chez moi:

   With MyPicture.ShapeRange
     .LockAspectRatio = msoTrue
     .Height = MaCell.RowHeight
   End With

A+

[tennis]

Merci HASCO,

Cette solution est bonne mais pose un gros problème lorsque on image est plus large que haute. En effet, dans ce cas précis, mon image sort complètement de la cellule sur le plan horizontale. Comment faire alors pour que Width prenne l'avantage sur Height.

Merci

[Hasco]

Et avec ceci:

Set MyPicture = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\checkGreen.gif")
With MyPicture.ShapeRange
.LockAspectRatio = msoTrue
If .Height > .Width Then
    .Width = MyCell.ColumnWidth
Else
    .Height = MyCell.RowHeight
End If
End With

[tennis]

Merci,

Je regrette mais ça ne fonctionne pas. La verticale correspond bien à la hauteur de cellule mais pour ces photos avec une grande hauteur horizontale (on va dire largeur), elles sortent toujours de ma cellule.

Je pensais justement à ce genre d'écriture. Je pense que vous n'etes pas loin de la vérité

Merci

[Hasco]

Re,

Je pense que cela le fera.

Dim ratio as single

With MyPicture.ShapeRange
'.LockAspectRatio = msoTrue
If .Height > .Width Then
    ratio = .Width / .Height
    .Height = .Height * ratio
    .Height = MyCell.RowHeight
Else
    ratio = .Height / .Width
    .Width = .widht * ratio
    .Width = MyCell.ColumnWidth
End If
End With
End Sub

[tennis]

Bonjour Hasco,

Désolé pour le retard... Merci pour votre travail mais je suis au regret de vous dire que ça ne marche pas. Qu'en est il chez vous ? L'avez vous testé ?

Merci encore

[Hasco]

Bonsoir,

Oui je l'ai tester avec des petite et grandes images. sinon je ne l'aurai pas envoyé.

Mais pour plus de sûreté je vais recommencer. A tout à l'heure

[wilfried_42]

Bonjour à tous

Set MyPicture = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Val & ".jpg")
With MyPicture.ShapeRange
    .LockAspectRatio = msotrue
    .Top = MyCell.Top 
    .Left = MyCell.Left
    if mycell.height> mycell.width then
          .Height = mycell.height
    else
          .Width = mycell.width
    end if
end with

si j'ai tout compris, ce n'est pas la taille de l'image qu'il faut tester, mais la taille de la cellule qui receptionne
une seule valeur est utile, avec .lockaspectratio = msotrue, le rapport hauteur, largeur est gardé

[Hasco]

bonsoir,

je confirme que cela fonction correctement chez moi.

Aller bonne soirée à tous, je vais manger

[tennis]

Bonsoir à vous 2,

Merci beaucoup ça marche... Désormais juste une dernière aide pour centrer cette image dans la cellule...

Merci encore, c'est parfait...