XL 2016 Appliquer redimensionnement d'images à une colonne entière

[Dvd1976]

Salut à tous,

j'ai cette petite macro qui fonctionne très bien mais elle s'applique à une cellule (A1) mais je souhaiterais que cela s'applique à toutes les cellule de la colonne A.

Le principe est de cliquer sur la cellule afin d'avoir la fenêtre d'insertion d'image qui s'ouvre automatiquement et qui redimensionne la photo automatiquement à la taille dela cellule

Après quelques recherches et petites modifs de cette macro, je ne suis pas arrivé à quelques chose de convaincant...

Avez-vous une idée ?

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

 

[soan]

Bonsoir Dvd1976,

essaye ce code VBA :

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim picToOpen$: Cancel = True
  With Target
    If .CountLarge > 1 Then Exit Sub
    If .Column <> 1 Then Exit Sub
  End With
  Application.ScreenUpdating = 0
  picToOpen = Application.GetOpenFilename( _
    "Pics (*.jpg;*.gif;*.png;*.jpeg), *.jpg;*.gif;*.png;*.jpeg")
  InsertPictureInRange picToOpen, Selection
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
  Dim p As Object, 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

soan

 

[Dvd1976]

Bonjour Soan,

Super ! ça fonctionne à merveille

Merci pour l'entraide