XL 2016 VBA - Range to HTML incluant les objets de la feuille (boutons, images, ...)

If [L7].Value = "patricktoulon" Then
    'Patrick's function to create the image files from the Range Shapes
    Call DrawingObjects_To_Png_File(Rng, ImagesDirectory)
Else
    'Dudu2's function to create the image files from the Range Shapes
    Call ShapesInRangeToImageFiles(Rng, ImagesDirectory)
End If

Option Explicit
Sub testnew()
    Dim Rng As Range, cheminfinal$
    Set Rng = Feuil1.[C4:I13]
    cheminfinal = ThisWorkbook.Path & "\imagescapturée"
    DrawingObjects_To_Png_File3 Rng, cheminfinal
End Sub
Function DrawingObjects_To_Png_File3(Rng As Range, dossier$)
   Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim WbK As Workbook, calque As Worksheet, nomHtml, tim, chemin$, ShP As Object
    tim = Timer
    nomHtml = "tempo"

    chemin = ThisWorkbook.Path & "\" & nomHtml
    If Dir(dossier, vbDirectory) <> "" Then Kill dossier & "\*": RmDir dossier
    MkDir dossier

     Set WbK = Workbooks.Add
    Set calque = WbK.Sheets(1)

    For Each ShP In Rng.Parent.DrawingObjects
        If Not Intersect(ShP.TopLeftCell, Rng) Is Nothing Then
            ShP.Copy: calque.Pictures.Paste
            WbK.SaveAs Filename:=chemin & ".htm", FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False
            Name chemin & "_fichiers\image001.png" As dossier & "\" & Replace(ShP.Name, " ", "_") & ".png"
            calque.DrawingObjects.Delete
        End If
    Next
    WbK.Close
    Kill chemin & ".htm"
    Kill chemin & "_fichiers\*": RmDir chemin & "_fichiers"
    MsgBox Format(Timer - tim, "#0.000 Sec")
End Function