Image - Загрузка изображения по пути (Win32 API)

По материалам: http://www.sql.ru/forum/304849/access-vba-kartinki-v-forme

Модуль Класса clsPictureData, метод Load которого загружает файл в Image либо через .Picture, либо через .PictureData; в последнем случае используется метафайл

'--------------------------------------------------------------------
' Module    : clsPictureData
' Author    : Бенедикт
' Purpose   : загружает файл в Image либо через .Picture, либо через .PictureData
'             в последнем случае используется метафайл
'--------------------------------------------------------------------
' Требуется библ. ссылка на OLE Automation
'--------------------------------------------------------------------
' По материалам: http://www.sql.ru/forum/actualthread.aspx?tid=304849

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 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 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 SetWindowExtExAny Lib "gdi32" _
   Alias "SetWindowExtEx" ( _
   ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, _
   lpSize As Any) As Long
Private Declare Function SetViewportExtExAny Lib "gdi32" _
   Alias "SetViewportExtEx" ( _
   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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   Destination As Any, Source As Any, ByVal Length As Long)

Private Const CF_ENHMETAFILE = 14
'-------------------------------------------------------------------------------

Private m_hEMF As Long


Public Function Load(ByVal FileName As String, Image As Image) As Boolean
Dim pic As StdPicture
Dim rc As RECT
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 nDotPos As Integer

ReleaseResources

'Выделение расширения имени файла, принятие решения, идти по длинному пути
'или по короткому.
    FileName = Trim$(FileName)
    nDotPos = InStrRev(FileName, ".")
    If nDotPos > InStrRev(FileName, "\") Then
        Select Case UCase$(Mid$(FileName, nDotPos + 1))
        Case "WMF", "EMF", "ICO", "BMP", "DIB":
           'Если хотим пользоваться STRETCH_HALFTONE (см. ниже),
           'то BMP и DIB из списка убрать.
           'Считаем, что окно фильтра для простых форматов не появляется,
           'грузим изображение через свойство Picture.
           On Error Resume Next
           Image.Picture = FileName
           Load = Err = 0
           On Error GoTo 0
           Exit Function
        End Select
    End If

'До конца функции - загрузка изображения через свойство PictureData.
    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
        Load = Err = 0
        On Error GoTo 0
        Exit Function
    End If

'Ожидается pic.Type=vbPicTypeBitmap=1,GetObjectType(pic.Handle)=OBJ_BITMAP=7
    If GetObjectType(pic.Handle) <> OBJ_BITMAP Then Exit Function

'Получаем заголовок битмапа, чтобы извлечь из него размеры изображения
'в пикселях
    cbSize = LenB(bm)
    cbCopied = GetObjectA(pic.Handle, cbSize, bm)
    If cbCopied <> cbSize Then Exit Function

'Считаем, что Image.Parent.hWnd - дескриптор окна формы
    hdcRef = GetDC(Image.Parent.hWnd)
    
    iWidthMM = GetDeviceCaps(hdcRef, HORZSIZE)
    iHeightMM = GetDeviceCaps(hdcRef, VERTSIZE)
    iWidthPels = GetDeviceCaps(hdcRef, HORZRES)
    iHeightPels = GetDeviceCaps(hdcRef, VERTRES)
    
    rc.Right = bm.bmWidth * iWidthMM * 100 / iWidthPels
    rc.Bottom = bm.bmHeight * iHeightMM * 100 / iHeightPels

'Создаём "усовершенствованный" метафайл в памяти
    hdcMeta = CreateEnhMetaFile(hdcRef, vbNullString, rc, vbNullString)

    If hdcMeta = 0 Then
        ReleaseDC Image.Parent.hWnd, hdcRef
        Exit Function
    End If
    
    SetMapMode hdcMeta, MM_ANISOTROPIC
    SetWindowExtExAny hdcMeta, bm.bmWidth, bm.bmHeight, ByVal 0&
    SetViewportExtExAny hdcMeta, bm.bmWidth, bm.bmHeight, ByVal 0&
'Access с целью совместимости с Win9x использует режим STRETCH_DELETESCANS,
'он быстрее, но менее качественный, чем STRETCH_HALFTONE. Последний доступен
'в NT/200x/XP.
    SetStretchBltMode hdcMeta, STRETCH_HALFTONE 'STRETCH_DELETESCANS
    
    hdcMem = CreateCompatibleDC(hdcRef)
    hbmpOld = SelectObject(hdcMem, pic.Handle)
    
    BitBlt hdcMeta, 0, 0, bm.bmWidth, bm.bmHeight, hdcMem, 0, 0, SRCCOPY
    
    SelectObject hdcMem, hbmpOld
    DeleteDC hdcMem
    ReleaseDC Image.Parent.hWnd, hdcRef
    Set pic = Nothing 'освобождаем память
    
    m_hEMF = CloseEnhMetaFile(hdcMeta)
    If m_hEMF = 0 Then Exit Function
    
    cbSize = GetEnhMetaFileBits(m_hEMF, 0, ByVal 0&)
    ReDim bPicData(0 To cbSize + 7) As Byte
    cbCopied = GetEnhMetaFileBits(m_hEMF, cbSize, bPicData(8))
    
    bPicData(0) = CF_ENHMETAFILE
    CopyMemory bPicData(4), m_hEMF, 4 'хотя можно и побайтно заполнить
    Image.PictureData = bPicData
    Erase bPicData 'освобождаем память
    
    Load = True
End Function
Private Sub ReleaseResources()
    If m_hEMF Then
        DeleteEnhMetaFile m_hEMF
        m_hEMF = 0
    End If
End Sub

Private Sub Class_Terminate()
    ReleaseResources
End Sub

Пример использования в форме (Обьект Picture = Me!Im_Picture)

Private Sub PictuereUPD()
' Загрузка изображения в обьект Picture : Me!Im_Picture
'--------------------------------------------------------------------
Dim pd As clsPictureData
Dim strPath As String

On Error GoTo PictuereUPD_Err
    
    Set pd = New clsPictureData
    
    If Not IsNull(Me!txtFileName) Then
        ' Получаем полный путь
        strPath = CurrentProject.Path & "\" & Me!txtFileName
        ' вписываем Полный путь в поле (чисто для наглядности)
        Me!txtFilePath = strPath
        ' Загрузка
        If pd.Load(strPath, Me!Im_Picture) Then
           If Not Me!Im_Picture.Visible Then Me!Im_Picture.Visible = True
        Else
           If Me!Im_Picture.Visible Then Me!Im_Picture.Visible = False
        End If
    Else 'Не указано или новая запись
        Me!txtFilePath = Null
        Me!Im_Picture.Visible = False
    End If

PictuereUPD_Bye:
    Set pd = Nothing
    Exit Sub

PictuereUPD_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure PictuereUPD", vbCritical, "Error!"
    Resume PictuereUPD_Bye
End Sub

Private Sub cmdUPD_Click()
'Кнопка "Обновить!" (изображение)
    PictuereUPD
End Sub

Private Sub Form_Current()
'Переход на тек запись
    PictuereUPD
End Sub

Achtung!
Требуется библ. ссылка на OLE Automation (C:\Windows\System32\stdole2.tlb)

MSA-2003 ( 910 kB) Пример