![]() |
![]() |
||
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
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! MSA-2003 ( 910 kB) Пример |
![]() ![]() |
||
L.E. 12.10.2022 |