Adding worksheet picture to a comment

[craig.penny]

Hello all you Excel nerds!

I'm trying to insert a picture into a cell comment. I've found plenty of threads but they are all for situations where the picture is not already within the worksheet or workbook. This is what I've been trying with all different things in place of the "???????" but I haven't figured it out.

Sub NamePic()
      Dim Pic As Object
      Dim Nm As String: Nm = "Picture 2"
      Dim s As Worksheet: Set s = ActiveSheet
      
      On Error Resume Next
      
      s.Cells(1, 2).Select
      Set Pic = s.Pictures(Nm)
      
      s.Cells(1, 5).AddComment
      s.Cells(1, 5).Comment.Shape.Height = Pic.Height
      s.Cells(1, 5).Comment.Shape.Width = Pic.Width
      s.Cells(1, 5).Comment.Shape.Fill.UserPicture   ????????
      
End Sub

"Picture 2" is definitely the right name but now what?

If you read this and you don't know the answer but just have an idea I'd love to hear it!

Thanks in advance!

 

[Greg Truby]

I'm doing a drive-by here because I don't know the answer and I have to leave here in a minute. But I'd hunt down the following -- Stephen Bullen & Rob Bovey did a table-driven commandbar building module for Excel 2003 and lower several years ago. Part of that logic involved a custom subroutine or function (I forget which) that they used to copy a picture from the surface of the worksheet and paste it into controls. It may be that the solution involves using their picture-pasting function? Complete shot in the dark and I apologize beforehand if it ends up being a snipe hunt.

Edit - not looking like you can PASTE in a picture interactively; so that might be a snipe hunt indeed.. Looks like you'd have to actually export the picture to a file and then import it.

 

[craig.penny]

No apologies, I appreciate any direction!

Thanks very much

 

[craig.penny]

It seems like the easiest way to handle it then is to save it to the desktop, import it, then delete it from the desktop. Is that how you would do it?

 

[RoryA]

As far as I know, that's the only way to do it. You cannot, as Greg mentioned, paste the picture in and userpicture has to take a file name.

 

[Greg Truby]

Just a note - while you might not have to export it to the user's desktop, it's probably not a bad idea (that or his myDocs). Don't use c:\ as a possible export path because under Win7, some users don't have write access to C:\ (I learned that one the hard way).

 

[RoryA]

Or save it to the workbook's path, since you need to have write access there as a rule.

 

[craig.penny]

I'm getting an error when I try to run this and I'm sure the solution is easy but I'm just not seeing it.

      Dim s As Worksheet: Set s = ActiveSheet
      Dim Nm As String: Nm = "CommentPic"
      Dim Pic As Object: Set Pic = s.Pictures(Nm)
      Dim Pth As String: Pth = CStr(ThisWorkbook.Path) & "\Temp.JPG"
    
      If Not Pic Is Nothing Then Pic.SaveAs (Pth)

I really appreciate your help!

 

[RoryA]

It's not that easy, I'm afraid. You'll need to use copypicture, then paste to a blank chart so that you can then export the chart to file.

 

[Jaafar Tribak]

Here is an adaptation of the Stephen Bullen use of the OleCreatePictureIndirect API :

In a standard module :

Option Explicit
 
'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 uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
 
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
 
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Integer) As Long
 
Private Declare Function CloseClipboard Lib "user32" _
() As Long
 
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
 
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const PICTYPE_BITMAP = 1
 
Private Sub Shape_to_Comment(Shape As Shape, Comment As Comment)
 
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim hPtr As Long
    Dim sTempFileName As String
 
    sTempFileName = ThisWorkbook.Path & "\temp.bmp"
 
    'Copy and retrieve the handle to the range Image
    Shape.CopyPicture xlScreen, xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
 
    'Create the interface GUID for the picture
    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.
    With uPicinfo
        .Size = Len(uPicinfo) ' Length of structure.
        .Type = PICTYPE_BITMAP ' Type of Picture
        .hPic = hPtr ' Handle to image.
        .hPal = 0 ' Handle to palette (if bitmap).
    End With
 
   'Create the Picture Object
   OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
 
    'Save Picture Object to disk.
    stdole.SavePicture IPic, sTempFileName
    
    Comment.Shape.Fill.UserPicture sTempFileName
    
    Kill sTempFileName
 
End Sub

Usage :

The one liner below will copy shape1 to the comment in cell A1 :

Sub Test()
 
    Shape_to_Comment ActiveSheet.Shapes(1), ActiveSheet.Range("a1").Comment
 
End Sub