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

По материалам: 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) Пример