none
What is the relationship between a Picture, a Shape, and a ShapeRange? RRS feed

Answers

All replies

  • IMHO the remarks in the documentation explains it well
    https://docs.microsoft.com/en-us/office/vba/api/excel.shape

    The only thing that is left is that any object that you put into a sheet becomes a shape, that is the "universal" container.

    Andreas.

    • Marked as answer by DavidThi808 Wednesday, October 24, 2018 9:14 PM
    Wednesday, October 17, 2018 5:19 PM
  • Hi Andreas;

    Thank you for the link, that helps. I see this as ShapeRange is a collection of Shape objects.

    How is a Picture contained in a Shape? Of great interest, how from a Shape can I get the Picture object in it?

    thanks - dave


    What we did for the last 6 months - Made the world's coolest reporting & docgen system even more amazing

    Wednesday, October 17, 2018 9:34 PM
  • How is a Picture contained in a Shape? Of great interest, how from a Shape can I get the Picture object in it?

    Hi Dave.

    The picture itself is anywhere deep deep inside the object model and unfortunately it is not possible to get the picture as object.

    It is possible to use the CopyPicture method of the Shape and get a copy into the clipboard, but if you want to get that back as IPicture object... theoretically possible, but you need tons of API code.

    Andreas.
    Friday, October 19, 2018 2:29 PM
  • It is possible to use the CopyPicture method of the Shape and get a copy into the clipboard, but if you want to get that back as IPicture object... theoretically possible, but you need tons of API code.

    Hi;

    Can you point me to the "tons of API code" to get a Picture from a Shape?

    thanks - dave


    What we did for the last 6 months - Made the world's coolest reporting & docgen system even more amazing

    Friday, October 19, 2018 3:01 PM
  • Make a new file, paste in a picture (as shape) and create an ActiveX Image control.
    Then execute sub Main from the code below.

    Andreas.

    Option Explicit
    
    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
    
    #If Win64 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    #Else
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    #End If
    
    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
    
    Sub Main()
      Dim S As Shape
      Dim I As Image
      Set S = ActiveSheet.Shapes(1)
      Set I = ActiveSheet.OLEObjects(1).Object
      I.Picture = PictureFromShape(S)
    End Sub
    
    Function PictureFromShape(ByVal S As Shape) As IPicture
      'Wandelt ein Shape über die Zwischenablage in ein Picture
      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" ', LastDLLErrorDescription
      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" ', LastDLLErrorDescription
      '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" ', LastDLLErrorDescription
      Set CreatePicture = IPic
    End Function
    

    Friday, October 19, 2018 4:03 PM