Skip to content

Instantly share code, notes, and snippets.

@Benshi
Last active January 15, 2022 00:50
Show Gist options
  • Save Benshi/2057bbea3825b64b017dbc9e5dd54589 to your computer and use it in GitHub Desktop.
Save Benshi/2057bbea3825b64b017dbc9e5dd54589 to your computer and use it in GitHub Desktop.
[Excel]シート上の画像をフォームに表示
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment