1

Topic: Loading of the image from a directory. Does not work at 64-bit Office.

I welcome all! Your help is necessary! At the Cyberforum found the code of loading of images from a directory http://www.cyberforum.ru/ms-access/thread1871730.html. Works well on 32-bit Office. On 64 does not want to work, produces the message. What it is necessary to change, what would work both in 32 and in 64?
The code following:

Private Sub PictuereUPD ()
' image Loading in  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
' we Receive a full path
strPath = CurrentProject. Path AND "" AND Me! txtFileName
' we inscribe the Full path in the field (purely for descriptive reasons)
Me! txtFilePath = strPath
' Loading
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 ' it is not specified or new record
Me! txtFilePath = Null
Me! Im_Picture. Visible = False
End If
PictuereUPD_Bye:
Set pd = Nothing
Exit Sub
PictuereUPD_Err:
MsgBox "Error" AND Err. Number AND vbCrLf AND Err. Description AND vbCrLf AND _
"in procedure PictuereUPD", vbCritical, "Error!"
Resume PictuereUPD_Bye
End Sub
Private Sub cmdUPD_Click ()
' the Button "to Update!" (Image)
PictuereUPD
End Sub
Private Sub Form_Current ()
' Passage on leaked record
PictuereUPD
End Sub

2

Re: Loading of the image from a directory. Does not work at 64-bit Office.

[quote = _ SergejVP] wladimirrr;
Result all text, including the class unit clsPictureData.

Here clsPictureData unit and what is necessary?

' Ìîäóëü Êëàññà: clsPictureData
'--------------------------------------------------------------------
' 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