Przykład Struktura BITMAP - 24 bajtowa struktura informacyjna bitmapy
Praktycznie mógłbym rozpocząć malowanie po bitmapie, ponieważ wiem jakie podstawowe właściwości ma załadowana bitmapa. Ale nie zawsze tak będzie, więc przed przystąpieniem do malowania po bitmapie pobiorę najistotniejsze dane bitmapy za pomocą funkcji GetObject(...) do zdefiniowanej poniżej struktury BITMAP.
Public Type BITMAP
bmType As Long 'typ bitmapy, musi być równy Zero
bmWidth As Long 'szerokość bitmapy w pikselach, musi być większa od Zera
bmHeight As Long 'wysokość bitmapy w pikselach, musi być większa od Zera
bmWidthBytes As Long 'określa liczbę bajtów w każdej linii skanowania. Wartość ta musi
'być liczbą parzystą, gdyż długość linii jest dopełniana do "słowa"
bmPlanes As Integer 'liczba warstw koloru
bmBitsPixel As Integer 'liczba bitów koloru na jeden piksel (głębia kolorów)
bmBits As Long 'wskaźnik do tablicy bajtów obrazu bitmapy
End Type
Operacje graficzne na pamięciowym kontekście urządzenia.
Aby móc wykonywać operację graficzne na bitmapie, uaktywnię ją w roboczym kontekście urządzenia, używając funkcji SelectObject(...), która zwróci mi uchwyt wcześniej aktywnej bitmapy. Bitmapa jest już uaktywniona, mogę więc wykonywać dowolne operacje graficzne na mojej bitmapie. Tak jak w przykładzie bmpMalowaniePoEkranie namaluję na bitmapie, w jej lewym górnym rogu, zielony kwadrat o wymiarach 100 x 100 pikseli. Nie będę sprawdzał wymiarów bitmapy .bmWidth i .bmHeight, czy są większe od 100, ponieważ jest to testowa bitmapa i znam jej dokładne wymiary. Do malowania użyję najprostszej (ale i bardzo wolnej) funkcji SetPixel(...).
Option Compare Database
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" ( _
ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" ( _
ByVal hInst As LongPtr, _
ByVal lpszName As String, _
ByVal uType As Long, _
ByVal cxDesired As Long, _
ByVal cyDesired As Long, _
ByVal fuLoad As Long) As LongPtr
Private Declare PtrSafe Function GetObject _
Lib "gdi32" Alias "GetObjectA" ( _
ByVal hObject As LongPtr, _
ByVal nCount As Long, _
ByRef lpObject As Any) As Long
Private Declare PtrSafe Function SelectObject _
Lib "gdi32" ( _
ByVal hdc As LongPtr, _
ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function SetPixel Lib "gdi32" ( _
ByVal hdc As LongPtr, _
ByVal x As Long, _
ByVal y As Long, _
ByVal crColor As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" ( _
ByVal hdc As LongPtr) As Long
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As LongPtr
End Type
#Else
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
ByVal hdc As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" ( _
ByVal hInst As Long, _
ByVal lpszName As String, _
ByVal uType As Long, _
ByVal cxDesired As Long, _
ByVal cyDesired As Long, _
ByVal fuLoad As Long) As Long
Private Declare Function GetObject _
Lib "gdi32" Alias "GetObjectA" ( _
ByVal hObject As Long, _
ByVal nCount As Long, _
ByRef lpObject As Any) As Long
Private Declare Function SelectObject _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function SetPixel Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
ByVal hdc As Long) As Long
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
#End If
Private Const IMAGE_BITMAP = 0 ' załadowana powinna być bitmapa.
Private Const IMAGE_ICON = 1 ' załadowana powinna być ikona.
Private Const IMAGE_CURSOR = 2 ' załadowany powinien być kursor.
Private Const LR_LOADFROMFILE = &H10 ' załaduj z pliku
Public Sub bmpMalowaniePoBitmapie()
#If VBA7 Then
Dim hdc As LongPtr
Dim hBitmap As LongPtr
Dim hBitmapOld As LongPtr
#Else
Dim hdc As Long
Dim hBitmap As Long
Dim hBitmapOld As Long
#End If
Dim bmBMP As BITMAP
Dim sPath As String
Dim x As Long
Dim y As Long
Dim lRet As Long
' będziemy pracowali na bitmapie MojaBitmapa.bmp w folderze bazy
sPath = Application.CurrentProject.Path & "\MojaBitmapa.bmp"
' utwórz kompatybilny kontekst urządzenia z ekranem
hdc = CreateCompatibleDC(0)
' załaduj bitmapę z zasobów dyskowych
hBitmap = LoadImage(hdc, sPath, IMAGE_BITMAP, 0&, 0&, LR_LOADFROMFILE)
' pobierz informacje o załadowanej bitmapie do struktury BITMAP
lRet = GetObject(hBitmap, LenB(bmBMP), bmBMP)
' wyświetl pobrane właściwości bitmapy
With bmBMP
Debug.Print "bmType", .bmType
Debug.Print "bmWidth", .bmWidth
Debug.Print "bmHeight", .bmHeight
Debug.Print "bmWidthBytes", .bmWidthBytes
Debug.Print "bmPlanes", .bmPlanes
Debug.Print "bmBitsPixel", .bmBitsPixel
Debug.Print "bmBits", .bmBits
End With
' by wykonywać jakiekolwiek operacje na załadowanej bitmapie,
' musimy ją wcześniej uaktywnić w kontekście urządzenia
hBitmapOld = SelectObject(hdc, hBitmap)
' namaluj w górnym lewym rogu bitmapy zielony kwadrat o wym. 100 x 100 pikseli
For x = 0 To 100
For y = 0 To 100
lRet = SetPixel(hdc, x, y, vbGreen)
Next
Next
' Na tym etapie kończę przetwarzanie testowej bitmapy. Pozostało tylko
' usunięcie (zwolnienie) z pamięci wszystkich niepotrzebnych obiektów
' uaktywnij poprzednio aktywną bitmapę
hBitmapOld = SelectObject(hdc, hBitmapOld)
' usuń już nieaktywną bitmapę
lRet = DeleteObject(hBitmap)
' usuń utworzony kontekst urządzenia
lRet = DeleteDC(hdc)
End Function
Dane w strukturze BITMAP
Kilka uwag o procedurze bmpMalowaniePoBitmapie()
Po zakończeniu wykonywania operacji graficznych, powinienem przetworzoną bitmapę wyświetlić w formancie Image Me.imgObrazek oraz zapisać na dysk w postaci bitmapy. By to zrobić, powinienem przekonwertować bitmapę o uchwycie hBitmap która została utworzona w kontekście urządzenia hdc na tablicę bajtów obrazu Image.PictureData. Niestety, nie będzie tak łatwo. W tym konkretnym przypadku przetwarzana bitmapa jest bitmapą 32-bitową, ponieważ kompatybilny kontekst urządzenia (w tym wypadku mój ekran) ma 32-bitowa głębię kolorów. Przy takiej głębi każdy piksel opisany jest przez 4 bajty. Konieczne by było napisanie funkcji konwertującej bitmapę 32-bit na bitmapę 24-bit. Dodatkowym utrudnieniem jest nowa właściwość w Access 2007+, a mianowicie „Picture Property Storage Format” („Format przechowywania właściwości obrazów”). Więcej szczegółów o tej właściwości można znaleźć na stronie Image.PictureData
Ja ograniczam się tylko do bitmap 24-bitowych (3 bajty na piksel). więc tym problemem nie będę się zajmował.