Урок 16. Использование внешних изображений на ленте Access (устарело, см. ур. 17).

Внимание! Урок устарел! Написанное ниже можно читать в ознакомительных целях с учётом того, что начиная с версии 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