Microsoft 365 Envoyer une image dans une cellule avec un userform

Private Sub CommandButton2_Click()
    Call PictureToCell(UserForm1.Image1, ActiveSheet.Range("B2"))
End Sub

Private Sub PictureToCell(PictureControl, Cell As Range, Optional InCell As Boolean = True)
    Dim FSO As Object
    Dim FullName As String
    Dim Picture As Object
    Dim Sh As Shape
    Dim Ratio As Single
    Dim Width As Single
    Dim Height As Single
    Const TemporaryFolder = 2
  
    'Delete existing picture at destination or same name
    For Each Sh In Cell.Parent.Shapes
        If Sh.Name = PictureControl.Name _
        Or (Sh.Top = Cell.Top And Sh.Left = Cell.Left) Then Sh.Delete
    Next Sh
  
    'Save Picture to temporary folder
    Set FSO = CreateObject("scripting.filesystemobject")
    FullName = FSO.GetSpecialFolder(TemporaryFolder).Path & "\" & FSO.gettempname
    SavePicture PictureControl.Picture, FullName
  
    'Image size
    If InCell Then
        Ratio = Application.Min(Cell.MergeArea.Width / PictureControl.Width, Cell.MergeArea.Height / PictureControl.Height)
    Else
        Ratio = 1
    End If
  
    Width = PictureControl.Width * Ratio
    Height = PictureControl.Height * Ratio
  
    'Insert Picture in the Worksheet
    Set Sh = Cell.Parent.Shapes.AddShape(msoShapeRectangle, Cell.Left, Cell.Top, Width, Height)
    Sh.Name = PictureControl.Name
    Sh.Fill.UserPicture FullName

    'delete temporary file
    FSO.deletefile FullName
End Sub

Private Sub CommandButton2_Click()
   Dim OOt As OLEObject, Img As MSForms.Image
   On Error Resume Next
   Set OOt = Feuil1.OLEObjects("ImgB2")
   On Error GoTo 0
   If OOt Is Nothing Then
      Set OOt = Feuil1.OLEObjects.Add("Forms.Image.1")
      OOt.Name = "ImgB2"
      OOt.Left = Feuil1.[B2].Left: OOt.Top = Feuil1.[B2].Top
      OOt.Width = Feuil1.[B2].MergeArea.Width: OOt.Height = Feuil1.[B2].MergeArea.Height
      Set Img = OOt.Object
      Img.PictureSizeMode = fmPictureSizeModeZoom
      Img.BackColor = &HC8BCB0: Img.BorderStyle = fmBorderStyleNone
   Else: Set Img = OOt.Object: End If
   Img.Picture = Image1.Picture
   End Sub

Public xRecherche As String
Public FichName As String
Private Sub CommandButton1_Click()
    xRecherche = Application.GetOpenFilename("Images Files (*.jpg;*.bmp;*.gif;*.tif), *.jpg;*.bmp;*.gif;*.tif", 1, "CHOISIR UNE IMAGE")
    If xRecherche = "" Then Exit Sub
    Image1.Picture = LoadPicture(xRecherche)
    FichName = Mid(xRecherche, InStrRev(xRecherche, "\") + 1)
    Me.Caption = FichName
End Sub

Private Sub CommandButton2_Click()
    Dim temp$, Destination As Range
    temp = Environ("userprofile") & "\DeskTop\imgtemp.jpg"
    SavePicture Image1.Picture, temp
    With Sheets("Feuil1")
        Set Destination = .[B2:E16]
        .Pictures.Insert (temp)
        place_l_image_au_centre_dans Destination, .Pictures(.Pictures.Count)
    End With
    Kill temp
End Sub


Sub place_l_image_au_centre_dans(rng As Range, Shp As Picture)
   'patricktoulon
   'redimentionne l'image le plus possible pour qu'elle rentre dans le range sans déformation
   With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        w = rng.Width       ' width  range
        h = rng.Height      ' height range
        If (w / h < ratio) Then 'comparaison des ratios(rng/shp)
            .Width = w - 2
        Else
            .Height = h - (2 / ratio)
        End If
        .Left = rng.Left + ((rng.Width - .Width) / 2)
        .Top = rng.Top + ((rng.Height - .Height) / 2)
        .Placement = 1
    End With
End Sub

Ratio = Application.Min(Cell.MergeArea.Width / PictureControl.Width, Cell.MergeArea.Height / PictureControl.Height).