CODEWITHSUNDEEP
excelvba
Michael Rodby
Michael Rodby

Reputation: 376

Copy picture from Excel shape to Image object in VBA

I would like to copy a picture that has been inserted in an Excel spreadsheet to an Image object using VBA. Here is the code I tried:

Dim logo As Image
Set logo = New Image
logo.Picture = ThisWorkbook.Sheets("Sheet1").Pictures("Picture1")

The last line fails with a Type Mismatch error. When I look at logo.Picture in a watch window, it is listed as type Picture; when I assign an Object variable to the expression on the right of the equals sign, it is listed as type Picture/Picture. I'm not familiar enough with the VBA object hierarchy to know whether or not these types are related, nor how to convert from one to the other, and have not been able to find anything about that despite diligent Google searches.

If I replace the last line with this:

logo.Picture = LoadPicture(ThisWorkbook.Path & "\Logo.bmp")

the file loads and the rest of my program works. I have searched many postings here and elsewhere, and have not found anything useful, other than suggestions to export the image to a file and then import it to the Image object using LoadPicture. Any suggestions of how to get the picture from the worksheet instead of a file?

In case it matters, the rest of the code uses logo.Picture.Handle as a GDI bitmap HANDLE, and passes it to an external library to display the image on an external device. If there is a way to get a GDI bitmap HANDLE from a different object, that would work too.

Upvotes: 5

Views: 12582

Answers (4)

cyberponk
cyberponk

Reputation: 1766

This method worked for me:

First, create a new module and paste the PicturesAndShapes code (check below). Then to copy the image from a shape to your Image control, simply use this:

    Dim shp As Shape
    On Error Resume Next
    Set shp = Worksheets("SHEET NAME").Shapes("SHAPE NAME")
    If Err.Number = 0 Then
        On Error GoTo -1
        Logo.Picture = PictureFromShape(shp)
    End If
    On Error GoTo -1

PicturesAndShapes module:

Option Explicit

Private Const SRCCOPY As Long = &HCC0020
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
  peRed As Byte
  peGreen As Byte
  peBlue As Byte
  peFlags As Byte
End Type
Private Type LOGPALETTE
  palVersion As Integer
  palNumEntries As Integer
  palPalEntry(255) As PALETTEENTRY    ' Enough for 256 colors
End Type
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type
Private Type PICTDESC
  Size As Long
  Typ As Long
#If Win64 Then
  hPic As LongPtr
  hPal As LongPtr
#Else
  hPic As Long
  hPal As Long
#End If
End Type

#If VBA7 Then
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" ( _
    PICDESC As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture) As Long
#Else
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" ( _
    PICDESC As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture) As Long
#End If

Private Enum PictureType
  CF_BITMAP = 2
  CF_ENHMETAFILE = 14
End Enum

#If Win64 Then
Private Declare PtrSafe Function CloseClipboard Lib "user32" () 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 IsClipboardFormatAvailable Lib "user32" ( _
    ByVal wFormat As Long) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" ( _
    ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
Private Declare PtrSafe Function CopyImage Lib "user32" ( _
    ByVal Handle As LongPtr, ByVal imageType As Long, ByVal NewWidth As Long, _
    ByVal NewHeight As Long, ByVal lFlags As Long) As LongPtr
#Else
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" ( _
    ByVal wFormat As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" ( _
    ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" ( _
    ByVal Handle As Long, ByVal imageType As Long, ByVal NewWidth As Long, _
    ByVal NewHeight As Long, ByVal lFlags As Long) As Long
#End If

Public Function PictureFromShape(ByVal s As Shape) As IPicture
  If s Is Nothing Then Exit Function
  s.CopyPicture xlScreen, xlBitmap
  Set PictureFromShape = PictureFromClipboard
End Function

Public Function PictureFromClipboard() As IPicture
  'Return a bitmap or metafile picture from clipboard (type is auto detected)
  Const IMAGE_BITMAP = 0
  Const LR_COPYRETURNORG = &H4
#If VBA7 Then
  Dim hPic As LongPtr, hCopy As LongPtr
#Else
  Dim hPic As Long, hCopy As Long
#End If
  Dim Result As Long, PicType As PictureType
  Dim Count As Integer

  'Check if the clipboard contains a possible format
  If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
    PicType = CF_BITMAP
  ElseIf IsClipboardFormatAvailable(CF_ENHMETAFILE) <> 0 Then
    PicType = CF_ENHMETAFILE
  End If
  If PicType = 0 Then Err.Raise 70, "PictureFromClipboard", "No valid picture in " & _
    "clipboard"

  'Get access to the clipboard
  Do
    Result = OpenClipboard(0&)
    If Result <> 1 Then
      CloseClipboard
      DoEvents
      Sleep 10
    End If
    Count = Count + 1
  Loop Until Count = 10 Or Result = 1
  If Result <> 1 Then Err.Raise 70, "PictureFromClipboard", "Can not open the clipboard"

  'Get a handle to the image data
  hPic = GetClipboardData(PicType)
  If hPic = 0 Then
    CloseClipboard
    Err.Raise Err.LastDllError, "PictureFromClipboard"
  End If
  'Create our own copy of the image on the clipboard, in the appropriate format.
  If PicType = CF_BITMAP Then
    hCopy = CopyImage(hPic, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
  Else
    hCopy = CopyEnhMetaFile(hPic, vbNullString)
  End If
  If hCopy = 0 Then Err.Raise Err.LastDllError, "PictureFromClipboard"
  'Release the clipboard to other programs
  CloseClipboard
  'Convert it into a Picture object and return it
  Set PictureFromClipboard = CreatePicture(hCopy, 0, PicType)
End Function

#If VBA7 Then
Private Function CreatePicture(ByVal hPic As LongPtr, ByVal hPal As LongPtr, _
    Optional ByVal PicType As PictureType = CF_BITMAP) As IPicture
#Else
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, _
    Optional ByVal PicType As PictureType = CF_BITMAP) As IPicture
#End If
  Const PICTYPE_BITMAP As Long = 1
  Const PICTYPE_ENHMETAFILE As Long = 4
  Dim IPictureIID As GUID
  Dim IPic As IPicture
  Dim tagPic As PICTDESC

  'Fill in the IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  With IPictureIID
    .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

  'Set the properties on the picture object
  With tagPic
    .Size = Len(tagPic)
    .hPic = hPic
    Select Case PicType
      Case CF_BITMAP
        .Typ = PICTYPE_BITMAP
        .hPal = hPal
      Case CF_ENHMETAFILE
        .Typ = PICTYPE_ENHMETAFILE
        .hPal = 0
      Case Else
        Err.Raise 51, "CreatePicture", "Invalid picture type"
    End Select
  End With

  'Create a picture that will delete it's bitmap when it is finished with it
  OleCreatePictureIndirect tagPic, IPictureIID, 1, IPic
  If IPic Is Nothing Then Err.Raise Err.LastDllError, "CreatePicture"
  Set CreatePicture = IPic
End Function

Upvotes: 1

Excel Developers
Excel Developers

Reputation: 2825

There is no Image object in the Excel object model, but there is a Picture object (undocumented).

Dim logo As Picture
Set logo = ThisWorkbook.Sheets("Sheet1").Pictures("Picture1")

Upvotes: 0

Jamie
Jamie

Reputation: 51

Have you tried inserting it as an OLEObject?

Me.logo.Picture = ThisWorkbook.Worksheets("Sheet1").OLEObjects("Picture1").Object.Picture

The images you want to copy should be inserted into the worksheet as Image (ActiveX Control).

Upvotes: 1

user5305519
user5305519

Reputation: 3206

Define it as an Object instead and assign your image to it using Set:

Dim Logo As Object
Set Logo = ThisWorkbook.ActiveSheet.Pictures("Picture 1")

Upvotes: 0

Related Questions