Option Explicit
'Requires a reference to the "OLE Automation" type library
'----------------------------------------------------------------------------
' User-Defined Type for API Calls
'----------------------------------------------------------------------------
'Declare a Type to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Declare a Type to store the image information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'----------------------------------------------------------------------------
'Windows API Function Declarations
'----------------------------------------------------------------------------
'Does the clipboard contain a Metafile Picture?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the Clipboard
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a handle on the Picture
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Create a copy of the metafile
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Function PastePicture() As IPicture
Const lMETAFILE As Long = 14
Dim lPictureAvailable As Long
Dim lClipHandle As Long
Dim lPicHandle As Long
Dim lCopyHandle As Long
Dim uInterGUID As GUID
Dim uPictureInfo As uPicDesc
Dim lOLEHandle As Long
Dim iTempPicture As IPicture
'Check if the clipboard contains a picture file
lPictureAvailable = IsClipboardFormatAvailable(lMETAFILE)
If lPictureAvailable <> 0 Then
'Get a Handle on the Clipboard
lClipHandle = OpenClipboard(0&)
If lClipHandle > 0 Then
'Get a Handle on the Picture
lPicHandle = GetClipboardData(lMETAFILE)
'Make a local copy, in case the clipboard is changed
lCopyHandle = CopyEnhMetaFile(lPicHandle, vbNullString)
'Release Handle from Clipboard
lClipHandle = CloseClipboard
'Only Continue if we have a handle on the Picture
If lPicHandle <> 0 Then
' Create the Interface GUID (for the IPicture interface)
With uInterGUID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Fill UPictureInfo with necessary parts.
With uPictureInfo
.Size = Len(uPictureInfo) ' Length of structure.
.Type = 4 ' Type of Picture = Metafile
.hPic = lCopyHandle ' Handle to image.
.hPal = 0 ' Handle to palette.
End With
'Create the IPicture Object
lOLEHandle = OleCreatePictureIndirect(uPictureInfo, uInterGUID, True, iTempPicture)
If lOLEHandle = 0 Then
Set PastePicture = iTempPicture
End If
End If
End If
End If
End Function
