Добавление изображения в примечание ячейки из буфера обмена

[cent]

Помогите доработать макрос. Он должен добавить в меню ячейки пункт - "Вставить изображение", которое добавляет примечание к ячейке и делает фоном примечания картинку из буфера.
Нашел наработки по данный теме, но, как я уже написал выше, нужно чтобы картинка вставлялась из буфера обмена автоматически, а автор предлагает выбрать картинку из сохраненных в компьютере.

Что имеем (http://excelvba.ru/code/PictureInCellComment):

В модуль "ЭтаКнига" вставляем:

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.CommandBars("cell").Reset
End Sub

Private Sub Workbook_Open()
  MyComBars
End Sub

Также создаем новый модуль в книге, в который помещаем следующий код:

Option Explicit
Option Private Module

Sub MyComBars()
    Application.CommandBars("cell").Reset
    With Application.CommandBars("cell").Controls.Add(Type:=1, Before:=5)
        .OnAction = "AddImage"
        .Caption = "Вставить изображение"
    End With
End Sub

Sub AddImage()
    Dim ImaFile$
    
    If Selection.Cells.Count > 1 Then Exit Sub
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        ImaFile = .SelectedItems(1)
    End With
        
    On Error GoTo nexterr
    ActiveCell.ClearComments
    ActiveCell.AddComment.Shape.Fill.UserPicture (ImaFile)
    Exit Sub
nexterr:
    MsgBox "Можно выбирать только изображения!", vbCritical, "Ошибка"
    ActiveCell.ClearComments
End Sub

Screenshot_1.pngScreenshot_2.png

Собственно загвоздка у меня в том, что не могу найти функцию работы с буфером обмена, когда в нем не текст, а изображение, т.е. хочется в итоге иметь решение типа такого:

ImaFile = My.Computer.Clipboard.GetImage()
ActiveCell.AddComment.Shape.Fill.UserPicture (ImaFile)

Но выполнение макроса останавливается на My.Computer.Clipboard.GetImage().
Screenshot_3.png
Нужна замена этой функции для VBA, чтоб получился такой код:

Sub MyComBars()
    Application.CommandBars("cell").Reset
    With Application.CommandBars("cell").Controls.Add(Type:=1, Before:=5)
        .OnAction = "AddImage"
        .Caption = "Вставить изображение"
    End With
End Sub
 
Sub AddImage()
    Dim ImaFile$
 
    If Selection.Cells.Count > 1 Then Exit Sub
 
    ImaFile = My.Computer.Clipboard.GetImage()
 
    On Error GoTo nexterr
    ActiveCell.ClearComments
    ActiveCell.AddComment.Shape.Fill.UserPicture (ImaFile)
    Exit Sub
nexterr:
    MsgBox "Ошибка!", vbCritical, "Ошибка"
    ActiveCell.ClearComments
End Sub

Спасибо.

[EducatedFool]

вместо «My.Computer.Clipboard.GetImage» в VBA придется написать много строк кода
Нужный код можно найти здесь:
http://programmersforum.ru/showthread.php?t=54492
Там есть макрос SaveClipboardToBMP - создаст файл формата BMP из буфера обмена

а как из файла в примечание вставить - вы уже знаете

PS: чтобы сохранить файл в формате JPG - кода будет намного больше
(где-то тут на форуме тоже выкладывал)

[cent]

Сообщение от EducatedFool

вместо «My.Computer.Clipboard.GetImage» в VBA придется написать много строк кода
Нужный код можно найти здесь:
http://programmersforum.ru/showthread.php?t=54492
Там есть макрос SaveClipboardToBMP - создаст файл формата BMP из буфера обмена

а как из файла в примечание вставить - вы уже знаете

PS: чтобы сохранить файл в формате JPG - кода будет намного больше
(где-то тут на форуме тоже выкладывал)

Ок, уже работаю с ним, спасибо.

Одно не пойму, как там реализован процесс проверки содержимого буфера? Просто по наличию итогового файла? Если есть, значит в буфере была картинка?

З.Ы.
Вдогонку... как узнать размер картинки в буфере (ширина/высота), чтоб подобрать для него размер примечания?

[IgorGO]

размеры BMP-файла так

Type BitMapFileHeader
  bfType1 As Byte
  bfType2 As Byte
  bfSize As Long
  bfReserved1 As Integer
  bfReserved2 As Integer
  bfOffBits As Long
End Type

Type BitMapInfo
  biSize As Long
  biWidth As Long
  biHeight As Long
  iplanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type

Type BMPFile
     bmfh As BitMapFileHeader
     bmih As BitMapInfo
End Type



Sub ReadShowSameBMPInfo(fn As String)
  Dim bitmap1 As BMPFile
  Open fn For Binary As #1
  With bitmap1
    Get #1, , .bmfh
    Get #1, , .bmih
    Close #1
    MsgBox "Type = " & Chr(.bmfh.bfType1) & Chr(.bmfh.bfType2) & Chr(10) & "Size = " & .bmih.biWidth & "x" & .bmih.biHeight, , fn
  End With
End Sub

Sub Start()
  ReadShowSameBMPInfo "i:\jpg\1.bmp"
End Sub

[cent]

EducatedFool, IgorGO, спасибо огромное за пинки в нужном направлении!
Цель достигнута, результат отвечает поставленной задаче.

Итак,
В модуль "ЭтаКнига" вставляем:

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.CommandBars("cell").Reset
End Sub

Private Sub Workbook_Open()
  MyComBars
End Sub

Также создаем новый модуль в книге, в который помещаем следующий код:

Option Explicit
Option Private Module

'Windows API Function Declarations
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'The API format types we need
Const CF_BITMAP = 2, IMAGE_BITMAP = 0, LR_COPYRETURNORG = &H4
'Declare a UDT to store a GUID for the IPicture OLE Interface
Public 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
Public Type uPicDesc
        Size As Long
        Type As Long
        hPic As Long
        hPal As Long
End Type

Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long
Public Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEMF As Long) As Long

Const CF_ENHMETAFILE As Long = 14

'''''''''''''''
Type BitMapFileHeader
  bfType1 As Byte
  bfType2 As Byte
  bfSize As Long
  bfReserved1 As Integer
  bfReserved2 As Integer
  bfOffBits As Long
End Type
Type BitMapInfo
  biSize As Long
  biWidth As Long
  biHeight As Long
  iplanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type
Type BMPFile
     bmfh As BitMapFileHeader
     bmih As BitMapInfo
End Type
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
Sub MyComBars()
    Application.CommandBars("cell").Reset
    With Application.CommandBars("cell").Controls.Add(Type:=1, Before:=5)
        .OnAction = "AddImage"
        .Caption = "Вставить изображение"
    End With
End Sub

Sub AddImage()
    Dim ImaFile As String
    If Selection.Cells.Count > 1 Then Exit Sub
        SaveClipboardToBMP
    ImaFile = SaveClipboardToBMP
    On Error GoTo nexterr
    ActiveCell.ClearComments
    ActiveCell.AddComment.Shape.Fill.UserPicture (ImaFile)
    ActiveCell.Comment.Shape.Width = ReadShowSameBMPInfo(ImaFile, 1)
    ActiveCell.Comment.Shape.Height = ReadShowSameBMPInfo(ImaFile, 2)
    Exit Sub
nexterr:
    MsgBox "В буфере нет изображения!", vbCritical, "Ошибка"
    ActiveCell.ClearComments
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function SaveClipboardToBMP() As String
        Dim fn As String
    On Error Resume Next
        fn = Clip2FileEx
        SaveClipboardToBMP = fn
    If Dir(fn) = "" Then MsgBox "Файл  " & fn & "  не найден", vbExclamation, "Файл не найден"
        Exit Function
End Function

Public Function Clip2FileEx() As String
    Dim strOutputPath As String, oPic As IPictureDisp, PicPath As String
    On Error Resume Next
        MkDir Environ("TEMP") & "\Excel\"
    PicPath = Environ("TEMP") & "\Excel\": PicPath = PicPath & "Picture" & Format(Now, "DD-MMM-YYYY_HH-NN-SS") & ".bmp"
    Set oPic = GetClipPicture()
    If Not oPic Is Nothing Then
        SavePicture oPic, PicPath
        Clip2FileEx = PicPath
    Else
        Clip2FileEx = ""
        'MsgBox "Unable to retrieve bitmap from clipboard"
    End If
End Function

Function GetClipPicture() As IPicture
    Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, hCopy As Long
    'Check if the clipboard contains a bitmap
    hPicAvail = IsClipboardFormatAvailable(CF_BITMAP)
    If hPicAvail <> 0 Then
        'Get access to the clipboard
        h = OpenClipboard(0&)
        If h > 0 Then
            'Get a handle to the image data
            hPtr = GetClipboardData(CF_BITMAP)
            hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            'Release the clipboard to other programs
            h = CloseClipboard
            'If we got a handle to the image, convert it into a Picture object and return it
            If hPtr <> 0 Then Set GetClipPicture = CreatePicture(hCopy, 0, CF_BITMAP)
        End If
    End If
End Function

Public Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
    ' IPicture requires a reference to "OLE Automation"
    Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
    'OLE Picture types
    Const PICTYPE_BITMAP = 1
    ' Create the Interface GUID (for the IPicture interface)
    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 = hPic    ' Handle to image.
        .hPal = 0    ' Handle to palette (if bitmap).
    End With
    ' Create the Picture object.
    r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
    ' Return the new Picture object.
    Set CreatePicture = IPic
End Function

Public Function ReadShowSameBMPInfo(fn As String, par As Byte) As Long      ' par=1 выдаст ширину изображения, par=2 выдаст высоту изображения,
  Dim bitmap1 As BMPFile
  Open fn For Binary As #1
  With bitmap1
    Get #1, , .bmfh
    Get #1, , .bmih
    Close #1
    Select Case par
        Case 1
            ReadShowSameBMPInfo = .bmih.biWidth
        Case 2
            ReadShowSameBMPInfo = .bmih.biHeight
    End Select
'    MsgBox "Type = " & Chr(.bmfh.bfType1) & Chr(.bmfh.bfType2) & Chr(10) & "Size = " & .bmih.biWidth & "x" & .bmih.biHeight, , fn
  End With
End Function

В итоге получаем пункт меню ячейки - "Вставить изображение", добавляющее к ячейке примечание с картинкой из буфера.

[Ральф Сэт]

Возможна ли адаптация для Win 64?

Скачал пример, при попытке нажать "Вставить изображение", выводит ошибку на строки

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long
Public Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEMF As Long) As Long

Поискал информацию, нашел где рекомендуют менять "Private Declare Function" на "Private Declare PtrSafe Function".

Попробовал, ошибка не выдается, но при клике "Вставить изображение" выводит, что в буфере нет изображения.

Может кто-то помочь?

[EducatedFool]

Ральф Сэт, там очень много надо в коде менять
в том числе определения переменных внутри функций

Т.е. менять вот такие строки:

Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, hCopy As Long

на 5 строк типа

    #If VBA7 Then
        Dim H As LongPtr, hPicAvail As LongPtr, hPtr As LongPtr, hPal As LongPtr, hCopy As LongPtr
    #Else
        Dim H As Long, hPicAvail As Long, hPtr As Long, hPal As Long, hCopy As Long
    #End If

и так во всех функциях
и еще надо обходить один глюк 64-битных систем

Зачем вам вообще через буфер обмена картинку гонять?
Почему напрямую из файла не вставить?

[Ральф Сэт]

EducatedFool, на самом деле уже пробовал просто через crtl-H заменить все Long на LongPtr, не помогло, та же ошибка про отсутствие картинки в буфере.

Если я правильно понимаю, конкретно мне, не нужны проверки #If Win64 Then и If VBA7 Then ? Если я не планирую использовать 32 битную Office.

На основе этого кода хотел попробовать сделать макрос, при выполнении которого выделенная область копируется в буфер картинкой и в соседнюю ячейку вставляется примечание с этим же скриншотом. Очень удобно, имхо, когда надо следить за изменением значений в таблице, плюс если прятать скриншот в примечание, он не будет так мешать.

[rediffusion]

@EducatedFool или ещё кто нибудь!

У меня есть вот этот макрос:

Sub Special_Note2_FillPicture(control As IRibbonControl)
    Dim myComm As Comment
      If Not ActiveCell.Comment Is Nothing Then
        If MsgBox("Ячейка уже содержит примечание, удалить?", 4) - 7 Then
          ActiveCell.Comment.Delete
        Else: Exit Sub
        End If
      End If

    Set myComm = ActiveCell.AddComment
        With myComm.Shape 'выставляем требуемый формат
          .Height = 110
          .Width = 200
          .AutoShapeType = 1             'форма
'          .Fill.UserTextured
          .Fill.UserPicture "C:\Users\Admin\Downloads\TEST.jpg" 'Вставить картинку
          .Line.ForeColor.RGB = RGB(255, 0, 0) 'цвет линии
          .DrawingObject.Font.Name = "Consolas" 'шрифт
          .DrawingObject.Font.FontStyle = "обычный"
          .DrawingObject.Font.Size = 8    'размер шрифта
        End With
          'эмулируем выбор пункта "Изменить примечание"
           SendKeys "+{F2}"
End Sub

Помогите допилить сюда открытие диалогового окна с выбором файла (то есть картинки):

Application.FileDialog(msoFileDialogFilePicker)

[rediffusion]

Кароче вот рабочий вариант:

Sub AddImage()
    Dim ImaFile$
    Dim myComm As Comment
 
    If Selection.Cells.Count > 1 Then Exit Sub
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        ImaFile = .SelectedItems(1)
    End With
 
  On Error GoTo nexterr
  ActiveCell.ClearComments
  
    Set myComm = ActiveCell.AddComment
        With myComm.Shape
          .Height = 110
          .Width = 200
          .AutoShapeType = 1             'форма
'          .Fill.UserTextured
          .Fill.UserPicture (ImaFile) 'Переменная в которой уже по сути наша картинка.
          .Line.ForeColor.RGB = RGB(255, 0, 0) 'цвет линии
          .DrawingObject.Font.Name = "Consolas" 'шрифт
          .DrawingObject.Font.FontStyle = "обычный"
          .DrawingObject.Font.Size = 8
          Exit Sub
nexterr:
    MsgBox "Можно выбирать только изображения!", vbCritical, "Ошибка"
    ActiveCell.ClearComments
        End With
          'эмулируем выбор пункта "Изменить примечание" (не робит)!
           SendKeys "+{F2}", True
End Sub

Но у меня тут не работают нажатия на клавиши "Shift+F2" который выполняется при помощи "SendKeys". Как заставить работать не знаю!?