VBCommons/api/z_PastePictureAPI.bas

Attribute VB_Name = "z_PastePictureAPI"
'================ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> Copy/Paste =============
' Shared module version: 20210228
' Required reference: OLE Automation

' PastePicture The entry point for the routine
' CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference
' ErrorDescription Get the error text for an OLE error code
Option Private Module
Option Explicit
Option Compare Text

' Declare a UDT 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 UDT to store the bitmap information
Private Type PictDescriptor
  size_ As LongLong
  type_ As LongLong
  hPic_ As LongPtr
  hPal_ As LongLong
End Type

'Does the clipboard contain a bitmap/metafile?
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

'Convert the handle into an OLE IPicture interface.
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (pDesct As PictDescriptor, refID As GUID, ByVal nPicHandle As Long, iPic As IPicture) As Long

'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" 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.
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal nHandle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'The API format types
Private Const CF_BITMAP = 2
Private Const CF_PALETTE = 9
Private Const CF_ENHMETAFILE = 14
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4

Public Function PastePicture(Optional nType& = xlPicture) As IPicture
  'Convert the type of picture requested from the xl constant to the API constant
  Dim lPicType&: lPicType = IIf(nType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
  
  'Check if the clipboard contains the required format
  Dim hPicAvail&: hPicAvail = IsClipboardFormatAvailable(lPicType)
  If hPicAvail = 0 Then _
    Exit Function
  
  Dim cbHandle&: cbHandle = OpenClipboard(0&)
  If cbHandle <= 0 Then _
    Exit Function
 
  'Get a handle to the image data
  Dim hPtr&: hPtr = GetClipboardData(lPicType)
  
  'Create our own copy of the image on the clipboard, in the appropriate format.
  Dim hCopy&
  If lPicType = CF_BITMAP Then
    hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
  Else
    hCopy = CopyEnhMetaFile(hPtr, vbNullString)
  End If
  
  'Release the clipboard to other programs
  cbHandle = CloseClipboard
  
  'If we got a handle to the image, convert it into a Picture object and return it
  If hPtr <> 0 Then _
    Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End Function

Private Function CreatePicture(ByVal hPic&, ByVal hPal&, ByVal lPicType) As IPicture
  'OLE Picture types
  Const PICTYPE_BITMAP = 1
  Const PICTYPE_ENHMETAFILE = 4
  
  ' Create the Interface GUID (for the IPicture interface)
  Dim IID_IDispatch As GUID
  With IID_IDispatch
    .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 uPicInfo with necessary parts.
  Dim uPicInfo As PictDescriptor
  With uPicInfo
    .size_ = Len(uPicInfo) ' Length of structure.
    .type_ = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
    .hPic_ = hPic ' Handle to image.
    .hPal_ = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap).
  End With
  
  ' Create the Picture object.
  Dim r&
  Dim iPic As IPicture
  r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, iPic)
  
  ' If an error occured, show the description
  If r <> 0 Then _
    Debug.Print "Create Picture: " & ErrorDescription(r)
  
  ' Return the new Picture object.
  Set CreatePicture = iPic
End Function


Private Function ErrorDescription(nErr&) 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
  Const S_OK = &H0
  
  Select Case nErr
    Case E_ABORT: ErrorDescription = " Aborted"
    Case E_ACCESSDENIED: ErrorDescription = " Access Denied"
    Case E_FAIL: ErrorDescription = " General Failure"
    Case E_HANDLE: ErrorDescription = " Bad/Missing Handle"
    Case E_INVALIDARG: ErrorDescription = " Invalid Argument"
    Case E_NOINTERFACE: ErrorDescription = " No Interface"
    Case E_NOTIMPL:  ErrorDescription = " Not Implemented"
    Case E_OUTOFMEMORY: ErrorDescription = " Out of Memory"
    Case E_POINTER:  ErrorDescription = " Invalid Pointer"
    Case E_UNEXPECTED:  ErrorDescription = " Unknown Error"
    Case S_OK: ErrorDescription = " Success!"
  End Select
End Function