Сохранить картинку из буфера обмена в файл

[McConst]

Добрый день.
Я могу поместить диапазон range  в виде картинки в буфер обмена следующим кодом

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

Public Sub ScrnToGif()
'Сохраняем скриншот в виде gif файла
Dim lastrow As Long
Dim ws As Worksheet, rng As Range

Set ws = Worksheets(1)
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).row + 3
Set rng = Range(ws.Cells(1,1), ws.Cells(lastrow, 10))
rng.CopyPicture

End Sub

А как теперь сохранить картинку, которая находится в буфере сразу в файл, например gif или png? Не могу найти, наверняка есть какой-нибудь ActiveX метод

[McConst]

Кажется я частично решил проблему, но слегка по другому.
В примере моего кода лист Excel превращается в картинку, копируется в буфер, оттуда нужно сбросить его в файл.
То есть требовалось сбросить в файл скриншот листа.
5 лет назад я уже создавал тему для сканирования экрана в массив.
Пример рабочий и его можно использовать для моей задачи. Для сброса скриншота, хранящегося в массиве в файл нужно только правильно сохранить данные согласно спецификации BMP-файла. Немного погуглил, получилось.

Код свёрнут ниже. Часть задекларированных API в коде лишние, остались от предыдущего проекта, но в целом для офиса 2003 работает без ошибок. Процедура TestScanScreen

[spoiler]

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


Option Explicit
 
'Примеры декларации для некоторых API на офис х64 здесь: http://www.cadsharp.com/docs/Win32API_PtrSafe.txt
'-----------------------------------------------------------------------------------------------------------------------
'Функции для работы с экраном и координатами форм
'
#If VBA7 Then
    'Функция получения координат прямоугольника-контрола
    Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As LongPtr
    'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
    Public Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
     'Освобождение контекстного устройства после вызова GetDC
    Public Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
    Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    'Получить системные параметры
    Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    'Получить RGB-цвет пикселя по его координатам
    Public Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
    'Отрисовать RGB-точку
    Public Declare PtrSafe Function SetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    Declare PtrSafe Function SetPixelV Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    'Создание копии совместимого контекстного устройства DC
    Public Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    'Создается раст, совместимый с контекстным устройством DC
    Public Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    'Выбор объекта изображения в контекстное устройство DC
    Public Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    'Удаление контекстного устройства
    Public Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long
    'Перенос изображения из/в: контекст отображения <--> контекст памяти
    'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
    Public Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
     'Просканировать изображение в массив
    Public Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
     
#ElseIf Not Win64 Then 'Варинат для 2003 офиса на Win 32
 
    'Функция получения координат прямоугольника-контрола
    Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
    Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
    'Освобождение контекстного устройства после вызова GetDC
    Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    'Получить системные параметры
    Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
     
    'Преобразовать побитовое изображение в изображение для экрана (при рисовании)
    Public Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    'Просканировать изображение в массив
    Public Declare Function GetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    'Перенос изображения из/в: контекст отображения <--> контекст памяти
    'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
    Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
    'Создание копии совместимого контекстного устройства DC
    Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
    'Создается раст, совместимый с контекстным устройством DC
    Public Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    'Выбор объекта изображения в контекстное устройство DC
    Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
    'Удаление контекстного устройства
    Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
    Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
#ElseIf Win64 Then 'Варинат для 32bit офиса на Win 64
     
    'Функция получения координат прямоугольника-контрола
    Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As LongLong, lpRect As RECT) As LongLong
    'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
    Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As LongLong) As LongLong
    'Освобождение контекстного устройства после вызова GetDC
    Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongLong, ByVal hdc As LongLong) As LongLong
    'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongLong, ByVal nIndex As LongLong) As LongLong
    'Получить системные параметры
    Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As LongLong) As LongLong
    'Получить RGB-цвет пикселя по его координатам
    Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As LongLong, ByVal x As LongLong, ByVal y As LongLong) As LongLong
     
    'Преобразовать побитовое изображение в изображение для экрана (при рисовании)
    Public Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hBitmap As LongLong, ByVal nStartScan As LongLong, ByVal nNumScans As LongLong, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As LongLong) As LongLong
    'Просканировать изображение в массив
    Public Declare Function GetDIBits Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hBitmap As LongLong, ByVal nStartScan As LongLong, ByVal nNumScans As LongLong, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As LongLong
    'Перенос изображения из/в: контекст отображения <--> контекст памяти
    'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
    Public Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC As LongLong, ByVal x As LongLong, ByVal y As LongLong, ByVal nWidth As LongLong, ByVal nHeight As LongLong, ByVal hSrcDC As LongLong, ByVal XSrc As LongLong, ByVal YSrc As LongLong, ByVal dwRop As LongLong)
    'Создание копии совместимого контекстного устройства DC
    Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongLong) As LongLong
    'Выбор объекта изображения в контекстное устройство DC
    Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hObject As LongLong) As LongLong
    'Удаление контекстного устройства
    Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongLong) As LongLong
#End If
 
Public Type RECT 'Тип, хранящий координаты прямоугольника контрола
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
'Константы функции GetDeviceCaps параметра nIndex
Public Const LOGPIXELSX As Long = 88 'Число пикселей на горизонтальный логический дюйм
Public Const HORZSIZE As Long = 4& 'Размер по горизонтали в пикселях
Public Const VERTSIZE As Long = 6& 'Размер по вертикали в пикселях
Public Const HORZRES As Long = 8 'Разрешение по горизонтали в пикселях
Public Const VERTRES As Long = 10 'Разрешение по вертикали в пикселях
Public Const BITSPIXEL As Long = 12 'Глубина цвета в битах
Public Const VREFRESH As Long = 116 'Частота кадров монитора в герцах
 
'Константы функции GetSystemMetrics
Public Const SM_CXSCREEN As Long = 0 'Ширина экрана в пикселях
Public Const SM_CYSCREEN As Long = 1 'Высота экрана в пикселях
 
'Константа функции GetDIBits
Public Const DIB_RGB_COLORS = &H0 'RGB-палитра
 
'Типы и константы для получения информации в BITMAP вид
Public Type BITMAPINFOHEADER
   bmSize As Long
   bmWidth As Long
   bmHeight As Long
   bmPlanes As Integer
   bmBitCount As Integer
   bmCompression As Long
   bmSizeImage As Long
   bmXPelsPerMeter As Long
   bmYPelsPerMeter As Long
   bmClrUsed As Long
   bmClrImportant As Long
End Type
Public Type RGBTRIPLE
   Blue As Byte
   Green As Byte
   Red As Byte
   rgbReserved As Byte
End Type
Public Type BITMAPINFO
   bmHeader As BITMAPINFOHEADER
   bmColors As RGBTRIPLE
End Type
 
Public Type BITMAPFILEHEADER '14 байт
     bfType As Integer
     bfSize As Long
     bfReserved1 As Integer
     bfReserved2 As Integer
     bfOffBits As Long
End Type
 
'Способы копирования функцией BitBlt в параметре dwRop
Public Const SRCCOPY = &HCC0020 'Полное копирование
 
Public Const BI_RGB As Long = 0 'Картинка в виде несжатого растра
'------------------------------------------------------------------------------
 

Public Sub TestScanScreen()
'Функция сканирования экрана в массив Picture
#If VBA7 Then
    Dim hdc As LongPtr  'DC экрана
    Dim hTmpDC As LongPtr ' Временное DC для сканирования изображения
    Dim hTmpBmp  As LongPtr 'Указатель на совместимый точечный рисунок
#Else
    Dim hdc As Long  'DC экрана
    Dim hTmpDC As Long ' Временное DC для сканирования изображения
    Dim hTmpBmp  As Long 'Указатель на совместимый точечный рисунок
#End If


Dim ScreenH As Long, ScreenW As Long 'Разрешение экрана
Dim Picture() As RGBTRIPLE 'Массив, куда сканируется изображение
Dim Bitp As Long 'Глубина цвета в битах (12 или 24)
 
'Dim ScreenW As Long, ScreenH As Long 'Ширина и высота экрана
Dim BMP As BITMAPINFO 'Переменная, хранящая информацию о bmp рисунке
Dim BMPFileHeader As BITMAPFILEHEADER
Dim Res
Dim BytesPerScanLine As Long
 
hdc = GetDC(Application.hwnd) 'Получаем весь экран рабочего стола
ScreenW = GetDeviceCaps(hdc, HORZRES) 'Ширина экрана в пикселях
ScreenH = GetDeviceCaps(hdc, VERTRES) 'Выстоа экрана в пикселях
 
Bitp = GetDeviceCaps(hdc, BITSPIXEL) 'Получаем глубину цвета
hTmpDC = CreateCompatibleDC(hdc) 'Создаем DC, совместимую с экранной областью
hTmpBmp = CreateCompatibleBitmap(hdc, ScreenW, ScreenH) 'Создаю холст экрана

'Объектом для TmpDC выбираем растровый рисунок (варианты: кисть, шрифт, перо...)
Res = SelectObject(hTmpDC, hTmpBmp)
 
'Попиксельное копирование изображения из DC экрана во временное DC памяти (hTmpDC)
'первая пара 0,0 - координаты X,Y блока изображения получателя
'ScreenW, ScreenH - ширина и высота копируемого изображения
'последняя пара 0,0 - координаты X,Y блока изображения источника
'SRCCOPY - полное копирование без обработки
Res = BitBlt(hTmpDC, 0, 0, ScreenW, ScreenH, hdc, 0, 0, SRCCOPY)
 
With BMP.bmHeader
   .bmSize = Len(BMP.bmHeader) 'Размер блока .bmHeader в байтах
   .bmBitCount = Bitp 'Цветовая палитра ресунка
   .bmClrImportant = 0
   .bmClrUsed = 0
   .bmCompression = BI_RGB 'Без сжатия
   .bmHeight = -ScreenH
   .bmWidth = ScreenW 'Ширина рисунка
   .bmPlanes = 1 'Количество битовых плоскостей
   BytesPerScanLine = ((((.bmWidth * .bmBitCount) + 31) / 32) * 4)
   .bmSizeImage = 0 'BytesPerScanLine * Abs(.bmHeight)
   .bmXPelsPerMeter = 0
   .bmYPelsPerMeter = 0
End With
 
'Определяем размеры массива под сканирование экрана
ReDim Picture(0 To ScreenW - 1, 0 To ScreenH - 1)

'Получаем попиксельную информацию с экрана в массив
Res = GetDIBits(hTmpDC, hTmpBmp, 0, ScreenH, Picture(0, 0), BMP, DIB_RGB_COLORS)
If Res = 0 Then
    Stop
End If

'Создаём заголовок файла BMP
With BMPFileHeader
    .bfType = &H4D42 ' "BM"
    .bfSize = Len(BMP.bmHeader) + Len(BMPFileHeader) + ScreenW * ScreenH * Len(Picture(0, 0))
    .bfReserved1 = 0
    .bfReserved2 = 0
    .bfOffBits = Len(BMP.bmHeader) + Len(BMPFileHeader)
End With


Open "D:\2.bmp" For Binary Access Write As #1
Put #1, , BMPFileHeader
Put #1, , BMP.bmHeader
Put #1, , Picture
Close #1


DeleteObject hTmpBmp 'Освобождаю системные ресурсы, занятые под точечный рисунок
DeleteDC hTmpDC 'Удаляем временно созданный DC
ReleaseDC 0, hdc 'Освобождаем контекстное DC
End Sub


[/spoiler]


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

[Дмитрий Щербаков(The_Prist)]

Может Вам подойдет метод чуть проще: Как сохранить картинки из листа Excel в картинки JPG

[McConst]

В коде по вашей ссылке есть один момент. Когда я преобразую диапазон в картинку, она уходит в буфер и эксель не возвращает ссылку на объект. Это первое. Далее идет создание объектов ChartObjects. Мне бы хотелось эту стадию не использовать, так как эксель со своими перегруженными объектами работает относительно медленно. Идеально обойтись средствами API.
На данный момент я нашел интересную ссылку вот здесь.
Через API можно получить ссылку на изображение в буфере и далее работать примерно так как в коде, который я уже приводил. Единственный момент - сохранение рисунка в виде .bmp - мне не нравится. Эти файлы занимают много места и работа с диском при конвертации .bmp файла в другой формат - тоже достаточно медленна операция. Хотелось бы сразу сохранять в виде .png или .gif. Excel методом .CopyPicture с параметрами по умолчанию в буфер картинку помещает в векторном виде, т.е. теоретически у неё должен быть очень маленький объем. Я немного почитал вот тут, из буфера можно достать объект с помощью соответствующих констант формата CF_..., но об этом упоминается только вскользь. Буду пока дальше разбираться.

Ваше предложение использовать ChartObject оставлю на потом, если другими способами не получится.