Внимание! Написанное ниже следует читать с учётом того, что начиная с версии 7.0 редактор Ribbon XML Editor поддерживает прямую работу с базами данных Access, и уже не требуется создавать временный файл Excel для хранения интерфейса Access. Всё остальное в этом уроке актуально!

На прошлом уроке мы коснулись возможности построения собственных лент для 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 целиком, загружаем базу. На ленте должна появиться наша вкладка с кнопками без изображений. Теперь у нас всё готово к вставке внешних изображений.

Способ 1 (loadImage)

Создание таблицы с изображениями

Добавляем в базу ещё одну системную таблицу, но уже с произвольным именем, но тоже начинающимися на USys (User-created System table, созданная пользователем системная таблица), например, «USys Изображения для ленты» с четырьмя полями: «ID» (тип «Счётчик»), «Иденификатор изображения» (тип «Короткий текст»), «Изображение» (тип «Вложение») и «Описание» (тип «Короткий текст»). Как видите, в именах таблиц и полей можно использовать русские буквы и пробелы. В случае использования пробелов не забываем затем в VBA-коде заключать такие имена в квадратные скобки. Не забываем также поле ID в таблице сделать ключевым, поставив туда курсор и нажав на кнопку «Ключевое поле».

Таблицу «USys Изображения для ленты» построчно заполняем идентификатором изображения и соответствующим внешним изображением. Поскольку сами изображения в таблице видны не будут, для нашего же удобства заполняем поле «Описание».

XML-код интерфейса и генерация модуля процедур обратного вызова

В Ribbon XML Editor в элемент <customUI> добавляем параметр loadImage со значением имени функции обратного вызова, которую мы напишем, и которая будет возвращать нам изображения по их идентификатору. В элементы, в которые мы будем вставлять внешние изображения, добавляем параметр image со значением идентификатора нужного изображения. Нажимаем на кнопку генерации функций обратного вызова и сохраняем полученный модуль с шаблоном нашей функции в файл. Подправленный XML-код интерфейса снова копируем из Ribbon XML Editor в USysRibbons вместо старого.

Подключение модулей в редакторе Visual Basic

1. Открываем в Access редактор Visual Basic (Alt+F11)
2. В контекстном меню базы данных выбираем «Import File…» и импортируем наш модуль.
3. Вставляем в тело нашей функции обратного вызова следующий код:




Dim s As String

s = DLookup("Изображение", "[USys Изображения для ленты]", "[Идентификатор изображения]='" & imageId & "'")

Set image = basGDIPlus.AttachmentToPicture("[USys Изображения для ленты]", "Изображение", s)




4. Создаём или импортируем вспомогательный модуль «basGDIPlus.bas».
5. В меню редактора Visual Basic открываем Tools -> References, прокручиваем список вниз и отмечаем галочкой Microsoft Office XX.0 Object Library, где XX — номер версии Access. Также проверяем, чтобы стояла галочка на «OLE Automation».
6. Сохраняем изменения и закрываем редактор Visual Basic.

Теперь надо перезагрузить Access с базой. Всё закрываем, снова открываем Access и загружаем нашу базу. На ленте появляется наша вкладка, содержащая кнопки с внешними изображениями.

Способ 2 (getImage)

Создание таблицы с изображениями

Добавляем в базу ещё одну системную таблицу, но уже с произвольным именем, но тоже начинающимися на USys (User-created System table, созданная пользователем системная таблица), например, «USys Изображения для ленты» с четырьмя полями: «ID» (тип «Счётчик»), «Иденификатор элемента» (тип «Короткий текст»), «Изображение» (тип «Вложение») и «Описание» (тип «Короткий текст»). Как видите, в именах таблиц и полей можно использовать русские буквы и пробелы. В случае использования пробелов не забываем затем в VBA-коде заключать такие имена в квадратные скобки. Не забываем также поле ID сделать ключевым, поставив в него курсор и нажав на кнопку «Ключевое поле».

Таблицу «USys Изображения для ленты» построчно заполняем идентификатором элемента интерфейса, в который нужно вставить изображение, и соответствующим внешним изображением. Поскольку сами изображения в таблице видны не будут, для нашего же удобства заполняем поле «Описание».

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

XML-код интерфейса и генерация модуля процедур обратного вызова

В Ribbon XML Editor в элементы, в которые мы будем вставлять внешние изображения, добавляем параметр getImage со значением имени общей функции обратного вызова, которая будет возвращать нам изображения по идентификатору вызвавшего её элемента. Нажимаем на кнопку генерации функций обратного вызова и сохраняем полученный модуль с шаблоном нашей функции в файл. Подправленный XML-код интерфейса снова копируем из Ribbon XML Editor в USysRibbons вместо старого.

Подключение модулей в редакторе Visual Basic

1. Открываем в Access редактор Visual Basic (Alt+F11)
2. В контекстном меню базы данных выбираем «Import File…» и импортируем наш модуль.
3. Вставляем в тело нашей функции обратного вызова следующий код:




Dim s As String

s = DLookup("Изображение", "[USys Изображения для ленты]", "[Идентификатор элемента]='" & control.id & "'")

Set image = basGDIPlus.AttachmentToPicture("[USys Изображения для ленты]", "Изображение", s)




4. Создаём или импортируем вспомогательный модуль «basGDIPlus.bas».
5. В меню редактора Visual Basic открываем Tools -> References, прокручиваем список вниз и отмечаем галочкой Microsoft Office XX.0 Object Library, где XX — номер версии Access. Также проверяем, чтобы стояла галочка на «OLE Automation».
6. Сохраняем изменения и закрываем редактор Visual Basic.

Теперь надо перезагрузить Access с базой. Всё закрываем, снова открываем Access и загружаем нашу базу. На ленте появляется наша вкладка, содержащая кнопки с внешними изображениями.

Код модуля «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