На прошлом уроке мы коснулись возможности построения собственных лент для Access. Была упомянута возможность использования на лентах собственных изображений. На этом уроке будут подробно рассмотрены два способа вывода изображений в элементы интерфейса — с помощью параметра loadImage корневого элемента customUI и с помощью параметра getImage целевого элемента интерфейса.
Для того, чтобы внедрить собственные изображения в базу данных Access и использовать их в элементах ленточного интерфейса, нужно помимо уже известной нам с прошлого урока системной таблицы USysRibbons с XML-кодом ленты создать ещё одну системную таблицу для хранения изображений.
Чтобы иметь возможность свободно пользоваться не только изображениями формата gif, bmp и jpeg но и png, а также рядом других форматов (полный список: bmp, gif, jpg, jpeg, tif, png, wmf, emf, ico), нам нужно будет подключить к базе сторонний модуль basGDIPlus, код которого будет приведён в конце урока.
Всё, что мы будем делать далее, проверялось в Access 2016, но должно также работать и на всех предыдущих версиях Access, вплоть до 2007-й.
XML-код для Access можно писать как в пустом редакторе, сохраняя его через экспорт в файл настроек интерфейса (Ctrl+E), так и на базе открытого документа, например, Excel. Во втором случае интерфейс можно не только сохранять как обычно, вместе с документом, но и частично отлаживать его в Excel, если в нём не используются специфичные для Access идентификаторы. Рассмотрим второй способ.
Итак, для построения, частичной отладки и хранения нашего XML-кода создаём в Excel документ xlsm. Сохраняем и открываем его в Ribbon XML Editor. Создаём интерфейс с новой вкладкой, группой и несколькими своими кнопками, на которых будем размещать наши внешние изображения. Как построить свою вкладку с группой и кнопками вы уже знаете из предыдущих уроков.
Начиная с версии 6.1 система автодополнения редактора Ribbon XML Editor поддерживает идентификаторы Access, которые включаются вместо идентификаторов текущего приложения (в нашем случае вместо идентификаторов Excel) галочкой «Режим Access» в правом нижнем углу вкладки «Интерфейс». Эта возможность может нам очень пригодиться в дальнейшем. Также в этой версии программы в справку добавлены списки идентификаторов вкладок и групп Access с их русскими названиями, что также существенно облегчает нам ориентирование в интерфейсе Access.
После того, как начальный код ленты построен, создаём в Access новую базу данных. Создаём в ней системную таблицу USysRibbons, как было описано на предыдущем уроке (имя этой таблицы зарезервировано для ленточных интерфейсов). Работаем с первой записью таблицы. Копируем в поле RibbonXML наш код из Ribbon XML Editor.
Поскольку поля таблиц Access не поддерживают табуляцию, перед копированием полезно будет отформатировать текст, нажав кнопку форматирования вместе с зажатой клавишей Shift. Код отформатируется, а все символы табуляции заменятся соответствующим количеством пробелов. При включённой галочке «Режим Access» можно вместе с кнопкой форматирования клавишу Shift и не удерживать, табуляция на пробелы в этом случае заменится по умолчанию.
Вводим в поле RibbonName название ленты, сохраняем базу, закрываем и снова открываем её. Не забываем добавить имя нашей ленты в настройки Access для текущей базы. Снова сохраняем базу, закрываем и открываем Access целиком, загружаем базу. На ленте должна появиться наша вкладка с кнопками без изображений. Теперь у нас всё готово к вставке внешних изображений.
Добавляем в базу ещё одну системную таблицу, но уже с произвольным именем, но тоже начинающимися на USys (User-created System table, созданная пользователем системная таблица), например, «USys Изображения для ленты» с четырьмя полями: «ID» (тип «Счётчик»), «Иденификатор изображения» (тип «Короткий текст»), «Изображение» (тип «Вложение») и «Описание» (тип «Короткий текст»). Как видите, в именах таблиц и полей можно использовать русские буквы и пробелы. В случае использования пробелов не забываем затем в VBA-коде заключать такие имена в квадратные скобки. Не забываем также поле ID в таблице сделать ключевым, поставив туда курсор и нажав на кнопку «Ключевое поле».
Таблицу «USys Изображения для ленты» построчно заполняем идентификатором изображения и соответствующим внешним изображением. Поскольку сами изображения в таблице видны не будут, для нашего же удобства заполняем поле «Описание».
- Открываем в Access редактор Visual Basic (Alt+F11)
- В контекстном меню базы данных выбираем «Import File…» и импортируем наш модуль.
- Вставляем в тело нашей функции обратного вызова следующий код:
Dim s As String
s = DLookup("Изображение", "[USys Изображения для ленты]", "[Идентификатор изображения]='" & imageId & "'")
Set image = basGDIPlus.AttachmentToPicture("[USys Изображения для ленты]", "Изображение", s)
- Создаём или импортируем вспомогательный модуль «basGDIPlus.bas».
- В меню редактора Visual Basic открываем Tools -> References, прокручиваем список вниз и отмечаем галочкой Microsoft Office XX.0 Object Library, где XX — номер версии Access. Также проверяем, чтобы стояла галочка на «OLE Automation».
- Сохраняем изменения и закрываем редактор Visual Basic.
Добавляем в базу ещё одну системную таблицу, но уже с произвольным именем, но тоже начинающимися на USys (User-created System table, созданная пользователем системная таблица), например, «USys Изображения для ленты» с четырьмя полями: «ID» (тип «Счётчик»), «Иденификатор элемента» (тип «Короткий текст»), «Изображение» (тип «Вложение») и «Описание» (тип «Короткий текст»). Как видите, в именах таблиц и полей можно использовать русские буквы и пробелы. В случае использования пробелов не забываем затем в VBA-коде заключать такие имена в квадратные скобки. Не забываем также поле ID сделать ключевым, поставив в него курсор и нажав на кнопку «Ключевое поле».
Таблицу «USys Изображения для ленты» построчно заполняем идентификатором элемента интерфейса, в который нужно вставить изображение, и соответствующим внешним изображением. Поскольку сами изображения в таблице видны не будут, для нашего же удобства заполняем поле «Описание».
Если одно изображение используется сразу в нескольких элементах интерфейса, то имеет смысл разделить нашу таблицу на две. В одной хранить изображения, а в другой идентификаторы и соответствующие им порядковые номера изображений первой таблицы. В этом случае код нашей процедуры обратного вызова будет на строчку больше, поскольку сначала надо будет найти номер изображения по идентификатору, и только потом изображение по найденному номеру.
В Ribbon XML Editor в элементы, в которые мы будем вставлять внешние изображения, добавляем параметр getImage со значением имени общей функции обратного вызова, которая будет возвращать нам изображения по идентификатору вызвавшего её элемента. Нажимаем на кнопку генерации функций обратного вызова и сохраняем полученный модуль с шаблоном нашей функции в файл. Подправленный XML-код интерфейса снова копируем из Ribbon XML Editor в USysRibbons вместо старого.
- Открываем в Access редактор Visual Basic (Alt+F11)
- В контекстном меню базы данных выбираем «Import File…» и импортируем наш модуль.
- Вставляем в тело нашей функции обратного вызова следующий код:
Dim s As String
s = DLookup("Изображение", "[USys Изображения для ленты]", "[Идентификатор элемента]='" & control.id & "'")
Set image = basGDIPlus.AttachmentToPicture("[USys Изображения для ленты]", "Изображение", s)
- Создаём или импортируем вспомогательный модуль «basGDIPlus.bas».
- В меню редактора Visual Basic открываем Tools -> References, прокручиваем список вниз и отмечаем галочкой Microsoft Office XX.0 Object Library, где XX — номер версии Access. Также проверяем, чтобы стояла галочка на «OLE Automation».
- Сохраняем изменения и закрываем редактор Visual Basic.
Код модуля «basGDIPlus.bas»:
Option Compare Database
Option Explicit
'Модуль для вставки изображений в формате .png в элементы ленточного интерфейса Access
'----------------------------------------------------
' Функция для иконок с поддержкой GDIPlus-API (GDIP) |
'----------------------------------------------------
' * Для версий Office 2007 и выше * |
'----------------------------------------------------
' (c) mossSOFT / Sascha Trowitzsch rev. 04/2009 |
' Germany, Berlin |
'----------------------------------------------------
' отредактировал и перевёл Брыкалин А.С. |
'----------------------------------------------------
'Необходимы ссылки на библиотеки:
'«OLE Automation» (stdole)
'«Microsoft Office XX.0 Object Library», где XX - номер версии Access.
Public Const GUID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" 'IPicture
'Пользовательские типы данных: ----------------------------------------------------------------------
Public Enum PicFileType
pictypeBMP = 1
pictypeGIF = 2
pictypePNG = 3
pictypeJPG = 4
End Enum
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Type TSize
x As Double
y As Double
End Type
Public Type RECT
Bottom As Long
Left As Long
Right As Long
Top As Long
End Type
Private Type PICTDESC
cbSizeOfStruct As Long
PicType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Type GDIPStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
UUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
count As Long
Parameter As EncoderParameter
End Type
'Объявления API: ----------------------------------------------------------------------------
'Преобразование формата windows bitmap к OLE-Picture :
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (lpPictDesc As PICTDESC, riid As GUID, ByVal fPictureOwnsHandle As Long, IPic As Object) As Long
'Получение типа-GUID из строки :
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pCLSID As GUID) As Long
'Функции для работы с памятью:
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByRef Source As Byte, ByVal Length As Long)
'Модули API:
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
'Таймер API:
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
'Функции потока OLE-Stream:
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef ppstm As Any) As Long
Private Declare Function GetHGlobalFromStream Lib "ole32.dll" (ByVal pstm As Any, ByRef phglobal As Long) As Long
'Объявления GDIPlus Flat-API: ----------------------------------------------------------------------------
'Инициализация GDIP:
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GDIPStartupInput, Optional ByVal outputbuf As Long = 0) As Long
'Разъединение GDIP:
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
'Загрузка GDIP-изображения из файла:
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal FileName As Long, bitmap As Long) As Long
'Создание области GDIP-графики из Windows-DeviceContext:
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, GpGraphics As Long) As Long
'Удаление области GDIP-графики:
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
'Копирование GDIP-изображения в графическую область:
Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal Graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
'Очищение выделенной памяти под битовый массив из GDIP:
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
'Получение windows bitmap указателя из GDIP-изображения:
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
'Получение Windows-Icon-Handle из GDIP-изображения:
Public Declare Function GdipCreateHICONFromBitmap Lib "gdiplus" (ByVal bitmap As Long, hbmReturn As Long) As Long
'Масштабирование размера GDIP-изображения:
Private Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
'Получение GDIP-изображения из Windows-Bitmap-Handle:
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As Long
'Получение GDIP-изображения из Windows-Icon-Handle:
Private Declare Function GdipCreateBitmapFromHICON Lib "gdiplus" (ByVal hicon As Long, bitmap As Long) As Long
'Получение ширины GDIP-изображения (в пикселях):
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
'Получение высоты GDIP-изображения (в пикселях):
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
'Сохранение GDIP-изображения в файл с требуемым форматом:
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
'Сохранение GDIP-изображения в поток OLE-Stream с требуемым форматом:
Private Declare Function GdipSaveImageToStream Lib "gdiplus" (ByVal image As Long, ByVal stream As IUnknown, clsidEncoder As GUID, encoderParams As Any) As Long
'Получение GDIP-изображения из OLE-Stream-Object:
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal stream As IUnknown, image As Long) As Long
'Создание GDIP-изображения из развёртки
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, bitmap As Long) As Long
'Получение DC GDIP-изображения
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, Graphics As Long) As Long
'Копирование содержания битового массива GDIP-изображения в другую DC изображения используя позиционирование
Private Declare Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal Graphics As Long, ByVal image As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long = 0, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
'-----------------------------------------------------------------------------------------
'Глобальные переменные модуля:
Private lGDIP As Long
Private bSharedLoad As Boolean
'-----------------------------------------------------------------------------------------
'Инициализация GDI+
Function InitGDIP() As Boolean
Dim TGDP As GDIPStartupInput
Dim hMod As Long
If lGDIP = 0 Then
If IsNull(TempVars("GDIPlusHandle")) Then 'Если lGDIP вылетает вследствие критической ошибки, восстанавливаем из Tempvars collection
TGDP.GdiplusVersion = 1
hMod = GetModuleHandle("gdiplus.dll") 'gdiplus.dll ещё не загружен?
If hMod = 0 Then
hMod = LoadLibrary("gdiplus.dll")
bSharedLoad = False
Else
bSharedLoad = True
End If
GdiplusStartup lGDIP, TGDP 'Получить персональный экземпляр gdiplus
TempVars("GDIPlusHandle") = lGDIP
Else
lGDIP = TempVars("GDIPlusHandle")
End If
AutoShutDown
End If
InitGDIP = (lGDIP > 0)
End Function
'Запланированная выгрузка GDI+ обрабатываемая для предотвращения утечки памяти
Private Sub AutoShutDown()
'Установка 5 секундного интервала перед следующей выгрузкой
'Эта IMO наиболие подходящая для циклов - но можете настроить её как душе угодно
If lGDIP <> 0 Then
TempVars("TimerHandle") = SetTimer(0&, 0&, 5000, AddressOf TimerProc)
End If
End Sub
'Обратный вызов для AutoShutDown
Private Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
'Debug.Print "GDI+ AutoShutDown", idEvent
If TempVars("TimerHandle") <> 0 Then
If KillTimer(0&, CLng(TempVars("TimerHandle"))) Then TempVars("TimerHandle") = 0
End If
ShutDownGDIP
End Sub
'Очистка GDI+
Sub ShutDownGDIP()
If lGDIP <> 0 Then
If KillTimer(0&, CLng(TempVars("TimerHandle"))) Then TempVars("TimerHandle") = 0
GdiplusShutdown lGDIP
lGDIP = 0
TempVars("GDIPlusHandle") = Null
If Not bSharedLoad Then FreeLibrary GetModuleHandle("gdiplus.dll")
End If
End Sub
'Загрузка картинки с использованием GDIP
'Этот метод эквивалентен LoadPicture() в библиотеке OLE-Automation (stdole2.tlb)
'Поддерживаемые форматы: bmp, gif, jpg, jpeg, tif, png, wmf, emf, ico
Function LoadPictureGDIP(sFileName As String) As StdPicture
Dim hBmp As Long
Dim hPic As Long
If Not InitGDIP Then Exit Function
If GdipCreateBitmapFromFile(StrPtr(sFileName), hPic) = 0 Then
GdipCreateHBITMAPFromBitmap hPic, hBmp, 0&
If hBmp <> 0 Then
Set LoadPictureGDIP = BitmapToPicture(hBmp)
GdipDisposeImage hPic
End If
End If
End Function
'Масштабирование изображения с GDIP
'bSharpen: TRUE=Thumb даёт дополнительную резкость
Function ResampleGDIP(ByVal image As StdPicture, ByVal Width As Long, ByVal Height As Long, _
Optional bSharpen As Boolean = True) As StdPicture
Dim lRes As Long
Dim lBitmap As Long
If Not InitGDIP Then Exit Function
If image.type = 1 Then
lRes = GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap)
Else
lRes = GdipCreateBitmapFromHICON(image.Handle, lBitmap)
End If
If lRes = 0 Then
Dim lThumb As Long
Dim hBitmap As Long
lRes = GdipGetImageThumbnail(lBitmap, Width, Height, lThumb, 0, 0)
If lRes = 0 Then
If image.type = 3 Then 'Image-Type 3 это Icon!
'Преобразование с этим методом GDI +:
lRes = GdipCreateHICONFromBitmap(lThumb, hBitmap)
Set ResampleGDIP = BitmapToPicture(hBitmap, True)
Else
lRes = GdipCreateHBITMAPFromBitmap(lThumb, hBitmap, 0)
Set ResampleGDIP = BitmapToPicture(hBitmap)
End If
GdipDisposeImage lThumb
End If
GdipDisposeImage lBitmap
End If
End Function
'Получить ширину и высоту изображения в пикселях с GDIP
'Вернуть значение как определённый пользователем тип TSize (X/Y как Long)
Function GetDimensionsGDIP(ByVal image As StdPicture) As TSize
Dim lRes As Long
Dim lBitmap As Long
Dim x As Long, y As Long
If Not InitGDIP Then Exit Function
If image Is Nothing Then Exit Function
lRes = GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap)
If lRes = 0 Then
GdipGetImageHeight lBitmap, y
GdipGetImageWidth lBitmap, x
GetDimensionsGDIP.x = CDbl(x)
GetDimensionsGDIP.y = CDbl(y)
GdipDisposeImage lBitmap
End If
End Function
'Вспомогательная функция для получения OLE-Picture из Windows-Bitmap-Handle
'Если bIsIcon = TRUE, то Icon-Handle фиксируется
Function BitmapToPicture(ByVal hBmp As Long, Optional bIsIcon As Boolean = False) As StdPicture
Dim TPicConv As PICTDESC, UID As GUID
With TPicConv
If bIsIcon Then
.cbSizeOfStruct = 16
.PicType = 3 'PicType Icon
Else
.cbSizeOfStruct = Len(TPicConv)
.PicType = 1 'PicType Bitmap
End If
.hImage = hBmp
End With
CLSIDFromString StrPtr(GUID_IPicture), UID
OleCreatePictureIndirect TPicConv, UID, True, BitmapToPicture
End Function
'Сохраняет bitmap в файл (с преобразованием формата!)
'image = объект StdPicture
'sFile = полный путь к файлу
'PicType = pictypeBMP, pictypeGIF, pictypePNG или pictypeJPG
'Quality: 0...100; (Качество сжатия, работает только для pictypeJPG!)
'Возвращает TRUE если завершилось успешно
Function SavePicGDIPlus(ByVal image As StdPicture, sFile As String, PicType As PicFileType, Optional Quality As Long = 80) As Boolean
Dim lBitmap As Long
Dim TEncoder As GUID
Dim ret As Long
Dim TParams As EncoderParameters
Dim sType As String
If Not InitGDIP Then Exit Function
If GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap) = 0 Then
Select Case PicType
Case pictypeBMP: sType = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeGIF: sType = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Case pictypePNG: sType = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeJPG: sType = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
End Select
CLSIDFromString StrPtr(sType), TEncoder
If PicType = pictypeJPG Then
TParams.count = 1
With TParams.Parameter ' Качество
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .UUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(CLng(Quality))
End With
Else
'Различает количество параметров для GDI+ 1.0 и GDI+ 1.1 в GIF-ах!!
If (PicType = pictypeGIF) Then TParams.count = 1 Else TParams.count = 0
End If
'Сохраняем GDIP-Image в файл:
ret = GdipSaveImageToFile(lBitmap, StrPtr(sFile), TEncoder, TParams)
GdipDisposeImage lBitmap
DoEvents
'Функция возвращает True, если появляется сгенерированный файл:
SavePicGDIPlus = (Dir(sFile) <> "")
End If
End Function
'Эта процедура аналогична процедуре SavePicGDIPlus (по параметрам), но отличается тем,
'что ничего не хранится в виде файла, а преобразование выполняется
'с помощью OLE-Stream-объект в байт-массив.
Function ArrayFromPicture(ByVal image As Object, PicType As PicFileType, Optional Quality As Long = 80) As Byte()
Dim lBitmap As Long
Dim TEncoder As GUID
Dim ret As Long
Dim TParams As EncoderParameters
Dim sType As String
Dim IStm As IUnknown
If Not InitGDIP Then Exit Function
If GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap) = 0 Then
Select Case PicType 'Выбор GDIP-Format-Encoders CLSID:
Case pictypeBMP: sType = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeGIF: sType = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Case pictypePNG: sType = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeJPG: sType = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
End Select
CLSIDFromString StrPtr(sType), TEncoder
If PicType = pictypeJPG Then 'Если JPG, установить дополнительный параметр
'для задания уровня качества
TParams.count = 1
With TParams.Parameter ' Качество
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .UUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(CLng(Quality))
End With
Else
'Различает количество параметров для GDI+ 1.0 и GDI+ 1.1 в GIF-ах!!
If (PicType = pictypeGIF) Then TParams.count = 1 Else TParams.count = 0
End If
ret = CreateStreamOnHGlobal(0&, 1, IStm) 'Создаём поток
'Сохраняем GDIP-Image в поток:
ret = GdipSaveImageToStream(lBitmap, IStm, TEncoder, TParams)
If ret = 0 Then
Dim hMem As Long, LSize As Long, lpMem As Long
Dim abData() As Byte
ret = GetHGlobalFromStream(IStm, hMem) 'Получить Memory-Handle из потока
If ret = 0 Then
LSize = GlobalSize(hMem)
lpMem = GlobalLock(hMem) 'Получить доступ к памяти
ReDim abData(LSize - 1) 'Размер массива
'Фиксация стека памяти из потока:
CopyMemory abData(0), ByVal lpMem, LSize
GlobalUnlock hMem 'Закрыть память
ArrayFromPicture = abData 'Результат
End If
Set IStm = Nothing 'Очистка
End If
GdipDisposeImage lBitmap 'Очистка GDIP-Image-Memory
End If
End Function
'Создание объекта картинки из вложения Access
'strTable: Таблица, содержащая вложенный файл картинки
'strAttachmentField: Название столбца с вложением
'strImage: Название изображения для поиска в записи с вложением
'? AttachmentToPicture("ribbonimages","imageblob","cloudy.png").Width
Public Function AttachmentToPicture(strTable As String, strAttachmentField As String, strImage As String) As StdPicture
Dim strSQL As String
Dim bin() As Byte
Dim nOffset As Long
Dim nSize As Long
strSQL = "SELECT " & strTable & "." & strAttachmentField & ".FileData AS data " & _
"FROM " & strTable & _
" WHERE " & strTable & "." & strAttachmentField & ".FileName='" & strImage & "'"
On Error Resume Next
bin = DBEngine(0)(0).OpenRecordset(strSQL, dbOpenSnapshot)(0)
If Err.Number = 0 Then
Dim bin2() As Byte
nOffset = bin(0) 'Первый байт Field2.FileData определяет смещение блока данных в файле
nSize = UBound(bin)
ReDim bin2(nSize - nOffset)
CopyMemory bin2(0), bin(nOffset), nSize - nOffset 'Скопировать файл в новый байтовый массив начиная со смещения
Set AttachmentToPicture = ArrayToPicture(bin2)
Erase bin2
Erase bin
End If
End Function
'Создать OLE-картинку из байтового массива PicBin()
Public Function ArrayToPicture(ByRef PicBin() As Byte) As StdPicture
Dim IStm As IUnknown
Dim lBitmap As Long
Dim hBmp As Long
Dim ret As Long
If Not InitGDIP Then Exit Function
ret = CreateStreamOnHGlobal(VarPtr(PicBin(0)), 0, IStm) 'Создать поток из стека памяти
If ret = 0 Then 'OK, начать GDIP:
'Конвертировать поток в GDIP-изображение:
ret = GdipLoadImageFromStream(IStm, lBitmap)
If ret = 0 Then
'Получить Windows-Bitmap из GDIP-изображения:
GdipCreateHBITMAPFromBitmap lBitmap, hBmp, 0&
If hBmp <> 0 Then
'Конвертировать bitmap в объект картинки:
Set ArrayToPicture = BitmapToPicture(hBmp)
End If
End If
'Чистка памяти ...
GdipDisposeImage lBitmap
End If
End Function
