Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 21.03.2016, 07:50   #1
cent
Пользователь
 
Аватар для cent
 
Регистрация: 26.12.2008
Сообщений: 73
Вопрос Добавление изображения в примечание ячейки из буфера обмена

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

Что имеем (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
Спасибо.
Вложения
Тип файла: xls С исходным кодом.xls (39.0 Кб, 14 просмотров)
Тип файла: xls Измененный код.xls (31.0 Кб, 17 просмотров)
Четко сформулированная задача - половина решения!
<= Спасибо оставляем в отзывах
cent вне форума Ответить с цитированием
Старый 21.03.2016, 18:12   #2
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Сообщений: 6,856
По умолчанию

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

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

PS: чтобы сохранить файл в формате JPG - кода будет намного больше
(где-то тут на форуме тоже выкладывал)
EducatedFool вне форума Ответить с цитированием
Старый 22.03.2016, 00:30   #3
cent
Пользователь
 
Аватар для cent
 
Регистрация: 26.12.2008
Сообщений: 73
По умолчанию

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

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

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

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

З.Ы.
Вдогонку... как узнать размер картинки в буфере (ширина/высота), чтоб подобрать для него размер примечания?
Четко сформулированная задача - половина решения!
<= Спасибо оставляем в отзывах
cent вне форума Ответить с цитированием
Старый 22.03.2016, 03:24   #4
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

размеры 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
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете

Последний раз редактировалось IgorGO; 22.03.2016 в 03:28.
IgorGO вне форума Ответить с цитированием
Старый 22.03.2016, 16:47   #5
cent
Пользователь
 
Аватар для cent
 
Регистрация: 26.12.2008
Сообщений: 73
Хорошо Решено!

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
В итоге получаем пункт меню ячейки - "Вставить изображение", добавляющее к ячейке примечание с картинкой из буфера.
Вложения
Тип файла: xls Книга1.xls (47.0 Кб, 38 просмотров)
Тип файла: zip Модули.zip (2.7 Кб, 30 просмотров)
Четко сформулированная задача - половина решения!
<= Спасибо оставляем в отзывах
cent вне форума Ответить с цитированием
Старый 07.04.2017, 11:38   #6
Ральф Сэт
Новичок
Джуниор
 
Регистрация: 05.07.2009
Сообщений: 2
По умолчанию

Возможна ли адаптация для 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".

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

Может кто-то помочь?
Ральф Сэт вне форума Ответить с цитированием
Старый 07.04.2017, 13:48   #7
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Сообщений: 6,856
По умолчанию

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

Т.е. менять вот такие строки:
Код:
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 вне форума Ответить с цитированием
Старый 08.04.2017, 18:07   #8
Ральф Сэт
Новичок
Джуниор
 
Регистрация: 05.07.2009
Сообщений: 2
По умолчанию

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

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

На основе этого кода хотел попробовать сделать макрос, при выполнении которого выделенная область копируется в буфер картинкой и в соседнюю ячейку вставляется примечание с этим же скриншотом. Очень удобно, имхо, когда надо следить за изменением значений в таблице, плюс если прятать скриншот в примечание, он не будет так мешать.
Ральф Сэт вне форума Ответить с цитированием
Старый 01.08.2019, 18:23   #9
rediffusion
Пользователь
 
Аватар для rediffusion
 
Регистрация: 30.05.2019
Сообщений: 36
По умолчанию

@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 вне форума Ответить с цитированием
Старый 03.08.2019, 20:11   #10
rediffusion
Пользователь
 
Аватар для rediffusion
 
Регистрация: 30.05.2019
Сообщений: 36
По умолчанию

Кароче вот рабочий вариант:
Код:
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". Как заставить работать не знаю!?
rediffusion вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
очистка буфера обмена beegl Общие вопросы Delphi 21 04.01.2017 11:01
Как вставить данные из буфера обмена в ячейки Excel без форматирования данных? protected_by Microsoft Office Excel 2 16.12.2013 19:38
Hook буфера обмена rust-02 Общие вопросы Delphi 0 20.09.2010 19:21
Вставка из буфера обмена volonc Microsoft Office Excel 12 17.07.2010 19:04
Копирование изображения из буфера обмена. yuran666666 Win Api 2 24.02.2010 13:39