[Excel]シート上の画像をフォームに表示

PictureFromClipboard.bas

Option Explicit

Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (ByRef lpPictDesc As PICTDESC_BITMAP, ByRef RefIID As Any, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long
Private Const PtrNull As LongPtr = 0
Private Type PICTDESC_BITMAP
    cbSizeofStruct As Long
    picType As Long
    hbitmap As LongPtr
    hpal As LongPtr
End Type

Public Function GetPictureFromClipboard() As stdole.IPictureDisp
    Const CF_BITMAP As Long = 2&
    Const CF_PALETTE As Long = 9&

    Set GetPictureFromClipboard = Nothing
    If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then
         Exit Function
    End If
    If OpenClipboard(PtrNull) = 0 Then
         Exit Function
    End If

    Dim uPict As PICTDESC_BITMAP
    uPict.cbSizeofStruct = Len(uPict)
    uPict.picType = 1&  '=PICTYPE_BITMAP
    uPict.hbitmap = GetClipboardData(CF_BITMAP)
    uPict.hpal = GetClipboardData(CF_PALETTE)
    CloseClipboard

    If uPict.hbitmap = PtrNull Then
        Exit Function
    End If

    Dim IID_IPictureDisp(1) As Currency     '{7BF80981-BF32-101A-8BBB-00AA00300CAB}, As stdole.IPictureDisp
    IID_IPictureDisp(0) = 116045007755044.6977@
    IID_IPictureDisp(1) = -612146501409303.8709@
    
    'Dim IID_IPicture(1) As Currency        '{7BF80980-BF32-101A-8BBB-00AA00300CAB}, As stdole.IPicture
    'IID_IPicture(0) = 116045007755044.6977@
    'IID_IPicture(1) = -612146501409303.8709@

    'Dim IID_IDispatch(1) As Currency       '{00020400-0000-0000-C000-000000000046}, As Object
    'IID_IDispatch(0) = 13.2096@
    'IID_IDispatch(1) = 504403158265495.5712@

    OleCreatePictureIndirect uPict, IID_IPictureDisp(0), 0&, GetPictureFromClipboard
End Function

' Private Sub CommandButton1_Click()
'     Sheet1.Pictures("Picture 1").Copy
'     Set Me.Image1.Picture = GetPictureFromClipboard()
' End Sub