'Класс для загрузки изображения в Access.Image через свойство Picture,
'либо через свойство PictureData.

Option Compare Database
Option Explicit

'---------------- Описания структур, функций, констант Win32 API ---------------
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Type BITMAP '24 bytes
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type

Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetObjectA Lib "gdi32" ( _
   ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function GetObjectType Lib "gdi32" ( _
   ByVal hgdiobj As Long) As Long
Private Const OBJ_BITMAP = 7
Private Const OBJ_ENHMETAFILE = 13

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 CreateCompatibleDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const HORZSIZE = 4           '  Horizontal size in millimeters
Private Const VERTSIZE = 6           '  Vertical size in millimeters
Private Const HORZRES = 8            '  Horizontal width in pixels
Private Const VERTRES = 10           '  Vertical width in pixels
Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y

Private Declare Function CreateEnhMetaFile Lib "gdi32" _
   Alias "CreateEnhMetaFileA" ( _
   ByVal hdcRef As Long, ByVal lpFileName As String, lpRect As RECT, _
   ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" ( _
   ByVal hEMF As Long) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" ( _
   ByVal hEMF As Long, ByVal cbBuffer As Long, lpbBuffer As Any) As Long

Private Declare Function SetMapMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nMapMode As Long) As Long
Private Const MM_ANISOTROPIC = 8 ' Map mode anisotropic

Private Declare Function SetWindowExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, _
   lpSize As Any) As Long
Private Declare Function SetViewportExtEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nX As Long, _
   ByVal nY As Long, lpSize As Any) As Long

Private Declare Function SetStretchBltMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Const STRETCH_DELETESCANS = 3
Private Const STRETCH_HALFTONE = 4

Private Declare Function BitBlt Lib "gdi32" ( _
   ByVal hdcDest As Long, ByVal x As Long, ByVal y As Long, _
   ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, _
   ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

Private Const CF_ENHMETAFILE = 14

Private Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type
Private Const VER_PLATFORM_WIN32_NT = 2
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" ( _
   lpVersionInformation As OSVERSIONINFO) As Long
'-------------------------------------------------------------------------------

Public Enum PictureQuality
   'pqLow
   pqMedium
   pqHigh
End Enum

Private Type TQuadBytes
   bByte(0 To 3) As Byte
End Type
Private Type TLong
   lLong As Long
End Type

Private m_hEMF As Long
Private m_pqQuality As PictureQuality
Private m_bIsNT As Boolean


Private Sub ReleaseResources()
 If m_hEMF Then
    DeleteEnhMetaFile m_hEMF
    m_hEMF = 0
 End If
End Sub

Private Sub Class_Initialize()
 Dim ovi As OSVERSIONINFO
 ovi.dwOSVersionInfoSize = Len(ovi)
 GetVersionEx ovi
 m_bIsNT = ovi.dwPlatformId >= VER_PLATFORM_WIN32_NT
 If m_bIsNT Then m_pqQuality = pqHigh Else m_pqQuality = pqMedium
End Sub

Private Sub Class_Terminate()
 ReleaseResources
End Sub

Public Property Get Quality() As PictureQuality
 Quality = m_pqQuality
End Property

Public Property Let Quality(ByVal NewQuality As PictureQuality)
 If (NewQuality >= pqMedium) And (NewQuality <= pqHigh) Then
    If (NewQuality < pqHigh) Or m_bIsNT Then
       m_pqQuality = NewQuality
    Else
       m_pqQuality = pqMedium
    End If
 Else
    Err.Raise 5
 End If
End Property


Public Function LoadFromFile(ByVal FileName As String, _
                             Image As Access.Image) As Boolean
 Dim Pic As IPictureDisp
 Dim sExtension As String
 Dim nDotPos As Integer
 
 ReleaseResources
 
 'Выделение расширения имени файла, принятие решения, идти по длинному пути
 'или по короткому.
 FileName = Trim$(FileName)
 nDotPos = InStrRev(FileName, ".")
 If nDotPos > InStrRev(FileName, "\") Then
    sExtension = UCase$(Mid$(FileName, nDotPos + 1))
    Select Case sExtension
    Case "WMF", "EMF", "ICO", "BMP", "DIB":
       If (m_pqQuality < pqHigh) Or _
          (sExtension <> "BMP") And (sExtension <> "DIB") Then
          'Считаем, что окно фильтра для простых форматов не появляется,
          'грузим изображение через свойство Picture.
          On Error Resume Next
          Image.Picture = FileName
          LoadFromFile = Err = 0
          On Error GoTo 0
          Exit Function
       End If
    End Select
 End If
 
 On Error Resume Next
 Set Pic = LoadPicture(FileName)
 On Error GoTo 0
 If Pic Is Nothing Then
    'Ещё попытка - для форматов типа PNG, PCX, TGA, не понимаемых LoadPicture
    On Error Resume Next
    Image.Picture = FileName
    LoadFromFile = Err = 0
    On Error GoTo 0
    Exit Function
 End If

 LoadFromFile = LoadFromIPicture(Pic, Image, True)
End Function


Public Function LoadFromIPicture( _
   SrcPic As IPictureDisp, ByVal Image As Access.Image, _
   Optional ByVal ReleasePicRef As Boolean = False) As Boolean
 Dim rc As RECT
 Dim hwndParent As Long
 Dim hdcRef As Long
 Dim hdcMeta As Long
 Dim hdcMem As Long
 Dim bm As BITMAP
 Dim cbSize As Long
 Dim cbCopied As Long
 Dim hbmpOld As Long
 Dim iWidthMM As Long
 Dim iHeightMM As Long
 Dim iWidthPels As Long
 Dim iHeightPels As Long
 Dim iDPIX As Long
 Dim iDPIY As Long
 Dim hEMF As Long
 
 'Загрузка изображения через свойство PictureData.
 ReleaseResources
 
 'Ожидается pic.Type=vbPicTypeBitmap=1,GetObjectType(pic.Handle)=OBJ_BITMAP=7,
 'или pic.Type=vbPicTypeEMetafile=4,GetObjectType(pic.Handle)=OBJ_ENHMETAFILE=13
 Select Case GetObjectType(SrcPic.Handle)
 Case OBJ_BITMAP:
    'Получаем заголовок битмапа, чтобы извлечь из него размеры изображения
    'в пикселях
    cbSize = LenB(bm)
    cbCopied = GetObjectA(SrcPic.Handle, cbSize, bm)
    If cbCopied <> cbSize Then Exit Function
   
    On Error Resume Next
    hwndParent = ParentForm(Image).hWnd
    On Error GoTo 0
    hdcRef = GetDC(hwndParent)
    
    iWidthMM = GetDeviceCaps(hdcRef, HORZSIZE)
    iHeightMM = GetDeviceCaps(hdcRef, VERTSIZE)
    iWidthPels = GetDeviceCaps(hdcRef, HORZRES)
    iHeightPels = GetDeviceCaps(hdcRef, VERTRES)
    iDPIX = GetDeviceCaps(hdcRef, LOGPIXELSX)
    iDPIY = GetDeviceCaps(hdcRef, LOGPIXELSY)
    
    'Размеры в сотых долях миллиметра
    rc.Right = SrcPic.Width   '= bm.bmWidth * 2540 / iDPIX
    rc.Bottom = SrcPic.Height '= bm.bmHeight * 2540 / iDPIY
   
    'Создаём "усовершенствованный" метафайл в памяти
    hdcMeta = CreateEnhMetaFile(hdcRef, vbNullString, rc, vbNullString)
    
    If hdcMeta = 0 Then
       ReleaseDC hwndParent, hdcRef
       Exit Function
    End If
   
    Dim iWEX As Long, iWEY As Long
    Dim iVEX As Long, iVEY As Long
    Dim iGCD As Long
    iWEX = bm.bmWidth * iWidthMM * iDPIX * 10
    iWEY = bm.bmHeight * iHeightMM * iDPIY * 10
    iVEX = bm.bmWidth * iWidthPels * 254
    iVEY = bm.bmHeight * iHeightPels * 254
    iGCD = GCD(GCD(GCD(iWEX, iWEY), iVEX), iVEY)
    SetMapMode hdcMeta, MM_ANISOTROPIC
    SetWindowExtEx hdcMeta, iWEX \ iGCD, iWEY \ iGCD, ByVal 0&
    SetViewportExtEx hdcMeta, iVEX \ iGCD, iVEY \ iGCD, ByVal 0&
    
    'Access с целью совместимости с Win9x использует режим STRETCH_DELETESCANS,
    'он быстрее, но менее качественный, чем STRETCH_HALFTONE. Последний доступен
    'в NT/200x/XP.
    Select Case m_pqQuality
    'Case pqLow:
    Case pqMedium:
       SetStretchBltMode hdcMeta, STRETCH_DELETESCANS
    Case pqHigh:
       SetStretchBltMode hdcMeta, STRETCH_HALFTONE
    End Select
    
    hdcMem = CreateCompatibleDC(hdcRef)
    hbmpOld = SelectObject(hdcMem, SrcPic.Handle)
    
    BitBlt hdcMeta, 0, 0, bm.bmWidth, bm.bmHeight, hdcMem, 0, 0, SRCCOPY
    
    SelectObject hdcMem, hbmpOld
    DeleteDC hdcMem
    ReleaseDC hwndParent, hdcRef
    If ReleasePicRef Then Set SrcPic = Nothing 'освобождаем память
    
    hEMF = CloseEnhMetaFile(hdcMeta)
    If hEMF = 0 Then Exit Function
    m_hEMF = hEMF
 
 Case OBJ_ENHMETAFILE:
    hEMF = SrcPic.Handle
    'Флаг ReleasePicRef намеренно игнорируем

 Case Else:
    Exit Function
 End Select
  
 cbSize = GetEnhMetaFileBits(hEMF, 0, ByVal 0&)
 ReDim bPicData(0 To cbSize + 7) As Byte
 PutPicDataLong bPicData, 0, CF_ENHMETAFILE
 PutPicDataLong bPicData, 4, hEMF
 cbCopied = GetEnhMetaFileBits(hEMF, cbSize, bPicData(8))
 
 Image.PictureData = bPicData
 Erase bPicData 'освобождаем память
 
 LoadFromIPicture = True
End Function

Private Function ParentForm(ByVal Ctl As control) As Form
 Dim oParent As Object
 Set oParent = Ctl
 On Error Resume Next
 Do
    Set oParent = oParent.Parent
 Loop Until (Err <> 0) Or (TypeOf oParent Is Form)
 Set ParentForm = oParent
End Function

Private Function GCD(ByVal a As Long, ByVal b As Long) As Long
 Do While (a <> 0) And (b <> 0)
    If a >= b Then a = a Mod b Else b = b Mod a
 Loop
 GCD = a + b
End Function

Private Sub PutPicDataLong(bData() As Byte, nPos As Long, ByVal lValue As Long)
 Dim L As TLong
 Dim QB As TQuadBytes
 L.lLong = lValue
 LSet QB = L
 bData(nPos + 0) = QB.bByte(0)
 bData(nPos + 1) = QB.bByte(1)
 bData(nPos + 2) = QB.bByte(2)
 bData(nPos + 3) = QB.bByte(3)
 nPos = nPos + 4
End Sub

Option Compare Database
Option Explicit

Private Enum BOOL
   FALSE_BOOL = 0&
   TRUE_BOOL = 1&
End Enum

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Declare Function CreateStreamOnHGlobal Lib "ole32" ( _
   hGlobal As Any, ByVal fDeleteOnRelease As BOOL, _
   Stream As IUnknown) As Long

Private Declare Function OleLoadPicture Lib "olepro32" ( _
   ByVal pStream As IUnknown, ByVal lSize As Long, _
   ByVal fRunmode As BOOL, riid As GUID, ppvPic As IPictureDisp) As Long

Private Const S_OK As Long = 0&

Public Function LoadPictureUsingStream(bPicData() As Byte) As IPictureDisp
 Dim lResult As Long
 Dim oStream As IUnknown
 Dim IID_IDispatch As GUID
 
 lResult = CreateStreamOnHGlobal(bPicData(LBound(bPicData)), FALSE_BOOL, _
                                 oStream)
 If lResult <> S_OK Then Exit Function
 
 With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
 End With
 lResult = OleLoadPicture(oStream, UBound(bPicData) - LBound(bPicData) + 1, _
                          TRUE_BOOL, IID_IDispatch, LoadPictureUsingStream)
End Function