Hello ,
This a lot of code for one macro that will paste what is on the clipboard into the Image object. Fortunately, it is very easy to use. Copy and paste the macro code into a separate VBA module in your workbook.
Example of Using the Macro
Image1.Picture = PastePicture
Macro Code to Paste Picture from Clipboard
'***************************************************************************
'*
'* MODULE NAME: Paste Picture
'* AUTHOR & DATE: STEPHEN BULLEN, Office Automation Ltd
'* 15 November 1998
'*
'* CONTACT: [email protected]
'* WEB SITE: http://www.oaltd.co.uk
'*
'* DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
'* This object can then be assigned to (for example) and Image control
'* on a userform. The PastePicture function takes an optional argument of
'* the picture type - xlBitmap or xlPicture.
'*
'* The code requires a reference to the "OLE Automation" type library
'*
'* The code in this module has been derived from a number of sources
'* discovered on MSDN.
'*
'***************************************************************************
Option Explicit
Option Compare Text
'=================================='
' User-Defined Types for API Calls '
'=================================='
'Declare the GUID Type structure 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 the Picture Description Type structure
Private Type PICTDESC
Size As Long
Type As Long
hPic As Long 'Holds the handle to a .bmp, .emf, .ico, .wmf file
Data1 As Long 'For a .bmp this holds the pallete handle hPal. For a .wmf this hold the xExt value.
Data2 As Long 'Used only with a .wmf to hold the yExt value.
End Type
'==================================='
' Windows API Function Declarations '
'==================================='
'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable _
Lib "user32.dll" _
(ByVal wFormat As Integer) As Long
'Open the clipboard to read and write data
Private Declare Function OpenClipboard _
Lib "user32.dll" _
(ByVal hWnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData _
Lib "user32.dll" _
(ByVal wFormat As Integer) As Long
'Copy data to the clipboard
Private Declare Function SetClipboardData _
Lib "user32.dll" _
(ByVal uFormat As Long, _
ByVal hData As Long) As Long
'Empty the clipboard
Private Declare Function EmptyClipboard _
Lib "user32.dll" () As Long
'Close the clipboard
Private Declare Function CloseClipboard _
Lib "user32.dll" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" _
(ByRef pPictDesc As PICTDESC, _
ByRef riid As GUID, _
ByVal fOwn As Long, _
ByRef ppvObj As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyEnhMetaFile _
Lib "GDI32.dll" _
Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As Long, _
ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyImage _
Lib "user32.dll" _
(ByVal hImage As Long, _
ByVal uType As Long, _
ByVal cxDesired As Long, _
ByVal cyDesired As Long, _
ByVal fuFlags As Long) As Long
'The API Constants needed
Const CF_BITMAP = &H2
Const CF_ENHMETAFILE = &HE
Const CF_METAFILEPICT = &H3
Const CF_PALETTE = &H9
Const IMAGE_BITMAP = &H0
Const IMAGE_ICON = &H1
Const IMAGE_CURSOR = &H2
Const LR_COPYRETURNORG = &H4
Function PastePicture(Optional xlPicType As Long = xlPicture) As IPicture
'Some pointers
Dim hClip As Long
Dim hCopy As Long
Dim hObj As Long
Dim hPal As Long
Dim hPicAvail As Long
Dim PicType As Long
Dim RetVal As Long
'Convert the Excel picture type constant to the correct API constant
PicType = IIf(xlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
'Check if the clipboard contains the required format
hPicAvail = IsClipboardFormatAvailable(PicType)
If hPicAvail <> 0 Then
'Get access to the clipboard
hClip = OpenClipboard(0&)
If hClip > 0 Then
'Get a handle to the object
hObj = GetClipboardData(PicType)
'Create a copy of the clipboard image in the appropriate format.
If PicType = CF_BITMAP Then
hCopy = CopyImage(hObj, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hObj, vbNullString)
End If
'Release the clipboard to other programs
RetVal = CloseClipboard
'If there is a handle to the image, convert it into a Picture object and return it
If hObj <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, PicType)
End If
End If
End Function
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal PicType) As IPicture
'IPicture requires a reference to "OLE Automation"
Dim Ref_ID As GUID
Dim IPic As IPicture
Dim PicInfo As PICTDESC
Dim RetVal As Long
'OLE Picture types
Const PICTYPE_UNINITIALIZED = -1 ' The picture object is currently uninitialized.
Const PICTYPE_NONE = 0 ' A new picture object is to be created without an initialized state. This value is valid only in the PICTDESC structure.
Const PICTYPE_BITMAP = 1 ' The picture type is a bitmap. When this value occurs in the PICTDESC structure, it means that the bmp field of that structure contains the relevant initialization parameters.
Const PICTYPE_METAFILE = 2 ' The picture type is a metafile. When this value occurs in the PICTDESC structure, it means that the wmf field of that structure contains the relevant initialization parameters.
Const PICTYPE_ICON = 3 ' The picture type is an icon. When this value occurs in the PICTDESC structure, it means that the icon field of that structure contains the relevant initialization parameters.
Const PICTYPE_ENHMETAFILE = 4 ' The picture type is a Win32-enhanced metafile. When this value occurs in the PICTDESC structure, it means that the emf field of that structure contains the relevant initialization parameters.
'Create a UDT to hold the reference to the interface ID (riid).
'IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
'StdPicture GUID {0BE35204-8F91-11CE-9DE3-00AA004BB851}
With Ref_ID
.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 PicInfo structure
With PicInfo
.Size = Len(PicInfo) ' Length of structure.
.Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
.hPic = hPic ' Handle to image.
.Data1 = IIf(PicType = CF_BITMAP, hPal, 0&) ' Handle to palette (if bitmap).
.Data2 = 0&
End With
'Create the Picture object.
RetVal = OleCreatePictureIndirect(PicInfo, Ref_ID, True, IPic)
'Check if an error ocurred
If Ret <> 0 Then
MsgBox "Create Picture Failed - " & GetErrMsg(Ret)
Set IPic = Nothing
Exit Function
End If
'Return the new Picture object.
Set CreatePicture = IPic
End Function
Private Function GetErrMsg(ErrNum As Long) As String
'OLECreatePictureIndirect return values
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Select Case ErrNum
Case E_ABORT
GetErrMsg = " Aborted"
Case E_ACCESSDENIED
GetErrMsg = " Access Denied"
Case E_FAIL
GetErrMsg = " General Failure"
Case E_HANDLE
GetErrMsg = " Bad/Missing Handle"
Case E_INVALIDARG
GetErrMsg = " Invalid Argument"
Case E_NOINTERFACE
GetErrMsg = " No Interface"
Case E_NOTIMPL
GetErrMsg = " Not Implemented"
Case E_OUTOFMEMORY
GetErrMsg = " Out of Memory"
Case E_POINTER
GetErrMsg = " Invalid Pointer"
Case E_UNEXPECTED
GetErrMsg = " Unknown Error"
End Select
End Function
Bookmarks