Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As CF) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As CF) As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
    Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PICTDESC, ByRef fiid As GUID, ByVal fOwn As LongPtr, ByRef lplpvObj As IPicture) As Long
    Private Type PICTDESC
        cbSizeofstruct As Long
        PICTYPE As PICTYPE 'Long
        hHandle As LongPtr
        Option1 As LongPtr
        Option2 As Long
    End Type
#Else
    Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As CF) As Long
    Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As CF) As Long
    Private Declare Function CloseClipboard Lib "user32.dll" () As Long
    Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PICTDESC, ByRef fiid As GUID, ByVal fOwn As Long, ByRef lplpvObj As IPicture) As Long
    Private Type PICTDESC
        cbSizeofstruct As Long
        PICTYPE As PICTYPE 'Long
        hHandle As Long
        Option1 As Long
        Option2 As Long
    End Type
#End If

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Enum CF
    BITMAP = 2
    PALETTE = 9
    ENHMETAFILE = 14
End Enum

Enum PICTYPE
    BITMAP = 1
    ENHMETAFILE = 4
End Enum

'指定したセルを含むオートシェイプをEMFに変換して返す
Private Function CreateEmfFromRange(r As Range) As Object
    Dim ShapeNameCollection As Collection
    Set ShapeNameCollection = New Collection
    Dim s As Shape
    For Each s In Me.Shapes
        If Not Application.Intersect(r, Me.Range(s.TopLeftCell, s.BottomRightCell)) Is Nothing Then
            Call ShapeNameCollection.Add(s.Name)
        End If
    Next
    Me.Shapes.Range(CollectionToArray(ShapeNameCollection)).Select
    Selection.Copy
    Set CreateEmfFromRange = CreatePictureFromClipboard()
    Exit Function
End Function

'クリップボードの画像をEMFで取得する
Private Function CreatePictureFromClipboard() As Object
    Dim uGUID As GUID
    Dim uPictDesc As PICTDESC
    Dim hHandle As Long
    If IsClipboardFormatAvailable(CF.ENHMETAFILE) = 0 Then Exit Function
    If OpenClipboard(0) Then
        hHandle = GetClipboardData(CF.ENHMETAFILE)
        hHandle = CopyEnhMetaFile(hHandle, vbNullString)
        Call CloseClipboard
    End If
    If hHandle = 0 Then Exit Function
    With uPictDesc
        .cbSizeofstruct = Len(uPictDesc)
        .PICTYPE = PICTYPE.ENHMETAFILE
        .hHandle = hHandle
    End With
    With uGUID
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    Call OleCreatePictureIndirect(uPictDesc, uGUID, 1, CreatePictureFromClipboard)
    Exit Function
End Function

'コレクションを配列に変換して返す
Private Function CollectionToArray(ByVal Source As Collection) As Variant
    Dim n As Long
    n = Source.Count - 1
    Dim Result As Variant
    ReDim Result(n)
    Dim i As Long
    For i = 0 To n
        Result(i) = Source(i + 1)
    Next
    CollectionToArray = Result
    Exit Function
End Function

Private Sub CommandButton1_Click()
    UserForm1.Image1.BorderStyle = fmBorderStyleNone
    UserForm1.Image1.PictureSizeMode = fmPictureSizeModeZoom
    UserForm1.Image1.Picture = CreateEmfFromRange(Range("A1"))
    UserForm1.Show
End Sub