Insertion et dimensionnement image

Bonjour,

J'ai trouvé en cherchant sur le web, une macro VBA permettant après un double click sur une cellule, d'insérer une image et de la redimensionner à la taille de la cellule en respectantses proportions.

Je suis sur Excel 2013. Cette cellule est une cellule fusionnée.

Cela fonctionne pour la plupart des images mais bizarrement cela ne fonctionne pas pour certaine . Et j'ai remarqué qu'il s'agit souvent de photo (notamment celles prises avec l'ordinateur ou une appareil photo) mais pas que.

Le problème de dimensionnement se situe uniquement sur la largeur de l'image. Quand je fais afficher les dimensions de l'image que la macro récupère la largeur est fausse tandis que la hauteur est bonne !

Savez vous comment résoudre ça ?

Merci beaucoup

1er code pour lancer l'insertion

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim picToOpen As String

If Not Application.Intersect(Target, Range("A1")) Is Nothing Then
ScreenUpdating = False
picToOpen = Application.GetOpenFilename("Pics (*.jpg;*.gif;*.png;*.jpeg), *.jpg;*.gif;*.png;*.jpeg")
InsertPictureInRange picToOpen, Selection
End If
End Sub

2nd code pour redimensionner l'image

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object
Dim t, l, w, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Width
h = .Height
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

Bonsoir,

Pas noté de problème selon le type d'images...

Quelques petites rectifications :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim picToOpen As String
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        Application.ScreenUpdating = False
        picToOpen = Application.GetOpenFilename( _
         "Pics (*.jpg;*.gif;*.png;*.jpeg), *.jpg;*.gif;*.png;*.jpeg")
        InsertPictureInRange picToOpen, Selection
        Cancel = True
    End If
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
    Dim p As Object
    Dim t!, l!, w!, h!
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    With TargetCells
        t = .Top
        l = .Left
        w = .Width
        h = .Height
    End With
    With p
        .Width = w
        If .Height > h Then
            .Height = h
            .Left = l + (w - .Width) / 2
            .Top = t
        Else
            .Left = l
            .Top = t + (h - .Height) / 2
        End If
    End With
End Sub

2 relativement importantes :

• le Cancel = True dans l'évènementielle (la 1re), qui évite l'édition de la cellule (ce qui obligeait à déplacer le curseur pour que l'image apparaisse).
• l'affinement du positionnement et dimensionnement : les proportions étant conservées, une fois qu'on a redimensionné en largeur, pour que l'image reste dans la cellule (sans déborder), il faut tester si sa hauteur (acquise) est supérieure à celle souhaitée, et on redimensionne la hauteur seulement dans ce cas (sinon la largeur sera de nouveau modifiée et débordera).

Les autres sont secondaires (comme les variables t, l et w non typées (le typage se fait individuellement) donc Variant, et j'ai donc retypé les 4 en Single (les coordonnées de position sur écran sont des données de type Single, inutile donc de les typer en Double)...)

Bonjour MFerrand,

Merci beaucoup pour ces deux modifications.

L'insertion et le dimensionnement fonctionnent parfaitement !

En vous souhaitant un excellent week-end !