Макрос для копирования диапазона ячеек, как картинки

[kompilainenn]

Господа хорошие, помогите. Нужен макрос, который бы делал следующее:

Брал выделенный диапазон ячеек в Calc (даже одна текущая ячейка считается тоже!)
Копировал этот диапазон в буфер обмена, как картинку (PNG или JPG не важно) с хорошим качеством и цветную
Не задавал никаких вопросов про качество и размер картинки (есть при стандартном экспорте дополнительные диалоги, так вот они в моем случае не треба)

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

[sokol92]

В буфер обмена не умею, в файл можно так:

Код Выделить Развернуть

' Сохраняет выделенную область как картинку в файле fileName
' fileType - тип файла: jpg или png. Умолчание - если расширение файла .png, то png, иначе jpg
Sub SelectionToPic(Byval fileName, Optional Byval fileType)
   Dim args(2) as new com.sun.star.beans.PropertyValue
   Dim args2(0) as new com.sun.star.beans.PropertyValue
 
   If IsMissing(fileType) Then
     fileType =IIf(Right(Lcase(fileName), 4)=".png", "png", "jpg")
   Else
     fileType=Lcase(fileType)
     If fileType<>"jpg" and fileType<>"png" Then fileType="jpg"
   End If 
   
   args2(0).Name="Quality": args2(0).Value=100  ' качество (максимум 100)
   
   args(0).Name = "FilterName"   : args(0).Value = "calc_" & FileType & "_Export"
   args(1).Name = "FilterData"   : args(1).Value=args2
   args(2).Name = "SelectionOnly": args(2).Value = True
   
  ThisComponent.storeToUrl(ConvertToURL(fileName), args)
End  Sub

Sub Test
  SelectionToPic("C:\temp\Test.jpg")
  SelectionToPic("C:\temp\Test.png")
End Sub

Сохранение в .png производится без потери качества, размер файла при этом значительно меньше, чем .jpg

[economist]

Что интересно - макрос 100% работает и во Writer, экспортируя всю текущую страницу ODT с разрешением примерно 160-200 dpi (очень подходит для архивного хранения в цвете, на лазерной распечатке - точь-в-точь как ксерокопия). Полезный пример! 

[kompilainenn]

В буфер обмена не умею

очень жаль, нужно в буфер обмена, файл на диске просто не нужен =(

[sokol92]

Уточнил макрос в #1.

Насколько я знаю, в буфер обмена выделенные ячейки копируются командой диспетчера .uno:Copy (сразу во многих форматах буфера обмена, включая графику), выделенный лист (листы) - командой диспетчера .uno:Move (c параметром Copy=True).

[kompilainenn]

Возможно можно обыграть использование функции Экспорт в (.uno:ExportTo)?

[sokol92]

Эту функцию я смотрел (обращение к ней записывает макрорекордер)  - функция вызывает диалог и после ответа пользователя формирует файл так же, как в ответе #1 (но в #1 действий пользователя не требуется). Проблема (как я понимаю) - занести в буфер обмена один формат вместо многих. Может быть, через методы LO Draw (сохранить диапазон Calc способом из #1 во временный файл png или jpg, открыть этот файл в LO Draw и скопировать в буфер обмена)? Получается (если получается) громоздко...

[kompilainenn]

хаха, забавно.
Копируем диапазон, как есть
Пробуем вставить в ГИМП - вставляет КАРТИНКУ, как и требуется. То есть, ЛО копирует в буфер в нескольких форматах сразу и среди форматов есть картинка!
А если вставить в почтовый клиент, то вставляет таблицей, которую можно править

Задача макроса - оставить только графический формат в буфере обмена при обычном копировании

[economist]

Ровно то что вы хотите делает расширение для Тундры https://addons.thunderbird.net/ru/thunderbird/addon/attach-from-clipboard/?src=search

[sokol92]

Собрал макрос SelectionAsPicToClip из лоскутов. Правда, пока "подмигивает".

Код Выделить Развернуть

Option Explicit
' --------------------------------------------------------------------------------
' Копирует диапазон ячеек как картинку в буфер обмена
Sub SelectionAsPicToClip()
  Dim tempFile, oDoc
  tempFile=GetTempFileName("png")
  SelectionToPic(tempFile)
  oDoc=StarDesktop.LoadComponentFromUrl(TempFile, "_blank", 0, Array()) 
  CopyToClipboard_Dispatch(oDoc)   
  oDoc.Close(False)
  Kill tempFile 
End Sub

' --------------------------------------------------------------------------------
' Сохраняет выделенную область как картинку в файле fileName
' fileType - тип файла: jpg или png. Умолчание - если расширение файла .png, то png, иначе jpg
Sub SelectionToPic(Byval fileName, Optional Byval fileType)
   Dim args(2) as new com.sun.star.beans.PropertyValue
   Dim args2(0) as new com.sun.star.beans.PropertyValue
 
   If IsMissing(fileType) Then
     fileType =IIf(Right(Lcase(fileName), 4)=".png", "png", "jpg")
   Else
     fileType=Lcase(fileType)
     If fileType<>"jpg" and fileType<>"png" Then fileType="jpg"
   End If 
   
   args2(0).Name="Quality": args2(0).Value=100  ' качество (максимум 100)
   
   args(0).Name = "FilterName"   : args(0).Value = "calc_" & FileType & "_Export"
   args(1).Name = "FilterData"   : args(1).Value=args2
   args(2).Name = "SelectionOnly": args(2).Value = True
   
  ThisComponent.storeToUrl(ConvertToURL(fileName), args)
End  Sub

' --------------------------------------------------------------------------------
' Копирует содержимое документа в буфер обмена
' Автор: A.Питоньяк
Sub CopyToClipboard_Dispatch(Byval oDoc)
  dim document   as object
  dim dispatcher as object
  document   = oDoc.CurrentController.Frame

  ' This next line was NOT added by the macro recorder.
  ' Without the next line, this fails in LO when called from a button.
  document.ContainerWindow.setFocus

  dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
  dispatcher.executeDispatch(document, ".uno:SelectAll", "", 0, Array())
  dispatcher.executeDispatch(document, ".uno:Copy", "", 0, Array())
End Sub

' Возвращает имя временного файла (URL) с расширением ext
Function GetTempFileName(ext)
  Dim oPathSubstitution
  oPathSubstitution=CreateUnoService("com.sun.star.util.PathSubstitution")
  GetTempFileName=oPathSubstitution.getSubstituteVariableValue("$(temp)") & "/T" & getSystemTicks() & "." & ext
End Function

[bigor]

А разве поправили выгрузку jpeg и png  с разрешением только 96 dpi ?

[kompilainenn]

А разве поправили выгрузку jpeg и png  с разрешением только 96 dpi ?

без понятия.
в принципе мне подсказали решение, которое не связано с Либрой, а связано с тем софтом, куда мне надо было картинку вставлять, там есть аналог Вставить как..., где можно выбрать ПНГ, после копирования из Кальк.