Также можно сделать и сохранение в другие форматы аналогично и открытие рисунка также из памяти.
- Код: Выделить всё
Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private 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
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GetHGlobalFromStream Lib "ole32" (ByVal ppstm As Long, hGlobal As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GdipSaveImageToStream Lib "gdiplus" (ByVal image As Long, ByVal Stream As IUnknown, clsidEncoder As Any, encoderParams As Any) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Const JpgCLSID As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}" ' Строковое представление CLSID jpeg энкодера
Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}" ' Строковое представление GUID качества сохранения
Private Const EncoderParameterValueTypeLong As Long = 4 ' Тип значений для энкодера 32 битный без знака
Private Sub Form_Load()
Dim dDc As Long ' Контекст устройства рабочего стола
Dim dhWnd As Long ' Хендл окна рабочего стола
Dim tBmp As Long ' Bitmap, в который копируем данные
Dim IStream As IUnknown ' Объект потока
Dim hMem As Long ' Хендл объекта памяти
Dim lSize As Long ' Размер памяти, предоставляемый объектом памяти
Dim lPt As Long ' Адрес памяти
Dim Dat() As Byte ' Данные рисунка, после кодирования (фактически бинарный JPG)
Dim fNum As Integer ' Файловый номер
Dim tDc As Long ' Временный контекст устройства
Dim oBmp As Long ' Старая картинка, выбраная во временный контекст
dhWnd = GetDesktopWindow() ' Получаем хендл окна рабочего стола
dDc = GetDC(dhWnd) ' Получаем контекст устройства рабочего стола
tDc = CreateCompatibleDC(dDc) ' Создаем совместимый с ним контекст
tBmp = CreateCompatibleBitmap(dDc, Screen.Width / _
Screen.TwipsPerPixelX, Screen.Height / _
Screen.TwipsPerPixelY) ' Создаем картинку по размеру экрана
oBmp = SelectObject(tDc, tBmp) ' Выбираем картинку во временный контекст
BitBlt tDc, 0, 0, Screen.Width / _
Screen.TwipsPerPixelX, Screen.Height / _
Screen.TwipsPerPixelY, dDc, 0, 0, vbSrcCopy ' Отрисовываем все с рабочего стола во временную картинку
SelectObject tDc, oBmp ' Очистка ресурсов ...
DeleteDC tDc
ReleaseDC dhWnd, dDc
If CreateStreamOnHGlobal(0&, 1&, IStream) Then _
MsgBox "Ошибка создание потока": _
DeleteObject (tBmp): Exit Sub ' Создаем объект потока
If Not SaveJPG(tBmp, IStream) Then _
MsgBox "Ошибка сохранение файла в поток": _
DeleteObject (tBmp): Exit Sub ' Сохраняем картинку
DeleteObject tBmp ' Очистка ресурсов
If GetHGlobalFromStream(ObjPtr(IStream), hMem) Then _
MsgBox "Ошибка получения хендла памяти": _
Exit Sub ' Получаем хендл объекта памяти потока
lSize = GlobalSize(hMem) ' Получаем размер объекта памяти
If lSize Then ' Если размер действительный...
lPt = GlobalLock(hMem) ' Блокируем и получаем указатель на него
ReDim Dat(0 To lSize - 1) ' Выделяем буфер, куда сохраняться данные
CopyMemory Dat(0), ByVal lPt, lSize ' Копируем данные из объекта памяти потока в буфер
GlobalUnlock hMem ' Разблокируем объект памяти
End If
' Для проверки, сохраним данные в файл
fNum = FreeFile
Open "D:\Temp.jpg" For Binary As fNum
Put fNum, , Dat
Close fNum
End Sub
' Процедура сохранения картинки в jpeg формате в поток
Private Function SaveJPG(hBitmap As Long, Stream As IUnknown, Optional Quality As Byte = 50) As Boolean
Dim SI As GdiplusStartupInput ' Для инициализации GDI+
Dim token As Long ' Маркер GDI +
Dim lBmp As Long ' Картинка GDI+
Dim JpgEnc As GUID ' CLSID jpeg энкодера
Dim Res As Long ' Результат операции сохранения в поток
Dim Par As EncoderParameters ' Параметры jpeg энкодера
SI.GdiplusVersion = 1 ' Параметры запуска
If GdiplusStartup(token, SI) Then Exit Function ' Запускаем GDI+
If GdipCreateBitmapFromHBITMAP(hBitmap, 0, lBmp) Then _
GdiplusShutdown (token): Exit Function ' Создаем GDI+ картинку из хендла картинки GDI
CLSIDFromString StrPtr(JpgCLSID), JpgEnc ' Получаем структуру CLSID для jpeg энкодера
' Задаем количество параметров для энкодера
Par.Count = 1 ' Количество - 1 (качество картинки)
Par.Parameter.NumberOfValues = 1 ' Количество значений в параметре 1
Par.Parameter.type = EncoderParameterValueTypeLong ' Значение параметра 32 битное без знака
Par.Parameter.value = VarPtr(CLng(Quality)) ' Указатель на значение качества сохранения
CLSIDFromString StrPtr("EncoderQuality"), _
Par.Parameter.GUID ' Получаем GUID качества сохранения
Res = GdipSaveImageToStream(lBmp, Stream, JpgEnc, Par) ' Сохраняем в поток
GdipDisposeImage lBmp ' Очистка ресурсов ...
GdiplusShutdown token ' Выключаем GDI+
If Res Then Exit Function ' Если неудачно сохранили, то выходим
SaveJPG = True ' Успешное выполнение
End Function