Access

  MS Access 2010+  |  Bitmapa *.bmp  |   VBA 7.0

• Czy plik jest nieskompresowaną bitmapą o 24-bitowej głębi kolorów?

We wszystkich przykładach dotyczących przetwarzania bitmap, korzystał będę z nieskompresowanych bitmap o 24-bitowej głębi kolorów. Pliki takie muszą spełnić następujące warunki:

Znak Informacja dodatkowa
  • musi posiadać 14 bajtowy nagłówek BITMAPFILEHEADER,
  • ma to być plik bitmapy o sygnaturze 'BM' (&H424D),
  • musi posiadać 40 bajtowy nagłówek BITMAPINFOHEADER,
  • musi posiadać 24 bitową głębię kolorów,
  • ma być zapisany bez użycia algorytmów kompresujących,
  • kierunek bajtów w tablicy bajtów obrazu bitmapy musi być z „z dołu do góry”,

• Gdzie bitmapa przechowuje wszystkie dane

Na stronie Struktura bitmapy opisałem dość dokładnie strukturę pliku bitmapy. Na samym początku pliku w 14 bajtowym nagłówku BITMAPFILEHEADER znajduje się najważniejsza, dwuznakowa sygnatura pliku 'BM'  (w zapisie heksadecymalnym &H424D). Znajdziemy tam jeszcze informacje o wielkości pliku i przesunięcie (offset) do bajtów bitmapy. Pozostałe informacje, takie jak rozmiar struktury nagłówka, szerokość i wysokość bitmapy, głębia kolorów, typ kompresji, rozdzielczość pozioma i pionowa zawarte są w 40 bajtowym nagłówku BITMAPINFOHEADER. Skoro już wiemy gdzie szukać informacji dotyczących bitmapy, to możemy zacząć realizować cel, jakim jest sprawdzenie czy plik *.bmp jest nieskompresowaną bitmapą o 24-bitowej głębi kolorów.

Funkcja sprawdzająca 24-bitową bitmapę.

Przed przystąpieniem do sprawdzania właściwości bitmapy, musimy sprawdzić, za pomocą funkcji plikFileExist(...), czy plik istniej na dysku. Jeżeli plik istnieje, to proforma sprawdzamy, czy zawiera co najmniej 58 bajtów (tyle zajmuje jednopikselowa 24-bitowa bitmapa). Potem otwieramy plik do odczytu i kolejno sprawdzamy poszczególne wymagane przeze mnie atrybuty. Najpierw wczytujemy dwa pierwsze bajty i porównujemy je z sygnaturą pliku 'BM'. Następnie do zmiennej bih zadeklarowanej jako As BITMAPINFOHEADER wczytujemy 40 bajtów z pliku, począwszy od 15 bajtu (1 bajt za 14 bajtowym nagłówkiem BITMAPFILEHEADER). Pozostaje tylko sprawdzenie, czy poszczególne elementy struktury w zmiennej bih spełniają zadane warunki.

⊗ Public Function bmpIsBmp24bit(sFileBmpPath As String) As Boolean
  • 'Sprawdza czy plik jest nieskompresowaną bitmapą o 24-bitowej głębi kolorów i kierunku czytania bajtów obrazu „z dołu do góry”. Korzystając funkcji plikFileExist(...), sprawdza, czy plik istniej na dysku. Jeżeli plik istnieje, sprawdzana jest wielkość pliku, która nie może być mniejsza od 58 bajtów (tyle zajmuje jednopikselowa 24-bitowa bitmapa). Potem plik bitmapy otwierany jest do odczytu i dwa pierwsze bajty pliku przypisane zostają do zmiennej iBmpSignature typu Integer, której wartość musi być równa &H424D, co odpowiada sygnaturze 'BM'. Następnie do zmiennej bih zadeklarowanej jako As BITMAPINFOHEADER wczytywanych jest 40 bajtów z pliku, począwszy od 15 bajtu (1 bajt za 14 bajtowym nagłówkiem BITMAPFILEHEADER). Potem kolejno sprawdzane są elementy struktury BITMAPINFOHEADER, które muszą spełniać zadane warunki:
    • bih.biSize = 40 'nagłówek bitmapy BITMAPINFOHEADER musi być 40-bajtowy
    • bih.biHeight >= 0 'bitmapa musi być „z dołu do góry”
    • bih.biBitCount = 24 'bitmapa musi mieć 24 bitową głębię kolorów
    • bih.biCompression = 0 'bitmapa nie może być skompresowana
  • argumenty:
    • sFileBmpPath
    • pełna ścieżka do pliku bitmapy
  • zwraca:
  • Przy powodzeniu, gdy sprawdzany plik jest nieskompresowaną bitmapą o 24-bitowej głębi kolorów o kierunku czytania bajtów obrazu „z dołu do góry”, zwraca TRUE. Przy niepowodzeniu, gdy plik nie spełnia jakiegokolwiek wymaganego warunku, funkcja generuje błąd wykonania i zwraca FALSE.
  • autor: Zbigniew Bratko
  • data: 04.02.2019
Option Compare Database
Option Explicit

Public Function bmpIsBmp24bit(sFileBmpPath As String) As Boolean
Dim bih             As BITMAPINFOHEADER
Dim ff              As Integer
Dim iBmpSignature   As Integer
Dim lFileSize       As Long
Const cProcName     As String = "Funkcja bmpIsBmp24bit(...)"

	If Not plikFileExist(sFileBmpPath) Then
		Err.Raise errFileNotExist, cProcName, _
							errBmpDescription(errFileNotExist)
	End If

	'sprawdź, wielkość bitmapy
	If FileLen(sFileBmpPath) < cBmpMinSize Then
		Err.Raise errBmpTooSmall, cProcName, _
							errBmpDescription(errBmpTooSmall)
	End If

	'otwórz plik i wczytaj dwa pierwsze bajty (sygnatura pliku)
	ff = FreeFile
	Open sFileBmpPath For Binary Access Read Lock Write As #ff
		Get #ff, , iBmpSignature
		If iBmpSignature <> cBmpIntSignature Then
			Close #ff
			Err.Raise errBmpFailSignature, cProcName, _
								errBmpDescription(errBmpFailSignature)
	 End If

		'wczytaj nagłówek BitmapInfoHeader i zamknij plik
		Get ff, cBmpBfhSize + 1, bih 'bytBih()
	Close #ff

	'sprawdź, czy nagłówek bitmapy jest 40-bajtowy
	If bih.biSize <> cBmpBihSize Then
		Err.Raise errBihFailSize, cProcName, _
							errBmpDescription(errBihFailSize)
	End If

	'sprawdź głębię kolorów
	If bih.biBitCount <> cBmpBitCount24 Then
		Err.Raise errBmpOnlyBitCount24, cProcName, _
								 errBmpDescription(errBmpOnlyBitCount24)
	End If

	'sprawdź, czy bitmapa jest skompresowana
	If bih.biCompression <> cBmpNotCompressed Then
		Err.Raise errBmpIsCompressed, cProcName, _
							errBmpDescription(errBmpIsCompressed)
	End If

	'sprawdź, czy bitmapa jest "z dołu do góry"
	If bih.biHeight < 0 Then
		Err.Raise errBmpIsTopDown, cProcName, _
							errBmpDescription(errBmpIsTopDown)
	End If

	bmpIsBmp24bit = True

End Function

Słów kilka o stałych, zmiennych, strukturach i funkcjach.

Niby tak proste zadanie jak sprawdzenie 24-bitowej bitmapy, rozrosło się do dość pokaźnych rozmiarów. Mam zamiar kontynuować temat przetwarzania 24-bitowej bitmap w MS Access, więc jest to jedyna okazja bym uporządkował nieco funkcje i procedury operujące na bitmapach. Na początek utworzyłem kilka modułów standardowych:

  • bas_apiFun - deklaracje wszystkich funkcji API
  • bas_apiStruct - deklaracje wszystkich struktur API
  • bas_bmpFun - własne funkcje graficzne
  • bas_Const - deklaracje stałych
  • bas_errBmp - obsługa błędów
  • bas_plikiFun - własne funkcje dotyczące przetwarzania plików

i mam nadzieję, że w miarę przybywania przykładów, i rozrastanie się modułów, jakoś utrzymam logiczny porządek we wszystkich utworzonych i tworzonych modułach

Option Compare Database
Option Explicit

' 14 bajtowy nagłówek pliku bitmapy.
' Zawiera informacje o rodzaju, rozmiarze i układzie pliku bitmapy (DIB).
Public Type BITMAPFILEHEADER
   bfType As Integer            'sygnatura BM (0x4D42) hex. &H424D
   bfSize As Long               'całkowity rozmiar pliku w bajtach
   bfReserved1 As Integer       'zarezerwowany - zazwyczaj równy ZERO
   bfReserved2 As Integer       'zarezerwowany - zazwyczaj równy ZERO
   bfOffBits As Long            'przesunięcie (w bajtach) do bajtów obrazu bitmapy
End Type
 
' 40 bajtowy nagłówek informacyjny bitmapy.
' Zawiera dane o właściwości bitmapy i organizacja jej kolorów.
Public Type BITMAPINFOHEADER
	biSize As Long               	'rozmiar struktury
	biWidth As Long              	'szerokość mapy bitowej w pikselach
	biHeight As Long             	'wysokość mapy bitowej w pikselach. Dla dodatniej wartość biHeight,
																'bitmapa jest typu „z dołu do góry” i jej punkt początkowy
																'znajduje się w lewym dolnym rogu. Dla ujemnych biHeight
																'bitmapa jest typu „z góry na dół” i jej początek
																'znajduje się w lewym górnym rogu.
	biPlanes As Integer          	'liczba warstw koloru, zawsze = 1
	biBitCount As Integer        	'liczba bitów koloru na jeden piksel (1,4,8,16,24,32)
	biCompression As Long        	'typ kompresji: BI_RGB = 0 (bez kompresji), BI_RLE8, BI_RLE4,
																'BI_BITFIELDS, BI_JPEG, BI_PNG
	biSizeImage As Long          	'wielkość mapy bitowej w bajtach, jeżeli bitmapa jest
																' nieskompresowana (element biCompression równy jest BI_RGB)
																'wartość biSizeImage może być ustawiona na ZERO
	biXPelsPerMeter As Long      	'rozdzielczość pozioma pixel/metr - zazwyczj ZERO,
																'wartość 2835 odpowiada rozdzielczości 72 dpi,
																'wartość 11811 odpowiada rozdzielczości 300 dpi
	biYPelsPerMeter As Long      	'rozdzielczość pionowa pixel/metr         ""          ""
	biClrUsed As Long            	'liczba użytych kolorów (liczba pozycji w tablicy kolorów),
																'dla biClrUsed=0 używana jest maksymalna ilość kolorów
																'określona przez wartości pola biBitCount
	biClrImportant As Long       	'liczba kolorów znaczących, zazwyczaj ZERO tzn. że wszystkie
																'kolory są potrzebne do wyświetlenia bitmapy
	'biClrUsed - dla 1-bitowych DIB = 0 lub 2
	'biClrUsed - dla 4-bitowych DIB = 0 lub 16, jeżeli 2-15 to wskazuje liczbę pozycji
							'w tablicy kolorów
	'biClrUsed - dla 8-bitowych DIB = 0 lub 256, jeżeli 2-255 to wskazuje liczbę pozycji
							'w tablicy kolorów
	'biClrUsed - dla 16, 24, 32 bitowych DIB zwykle wynosi ZERO
End Type
Option Compare Database
Option Explicit

Public Const cBmpIntSignature  As Integer = &H4D42   'sygnatura bitmapy "BM" jako liczba Integer
Public Const cBmpSignatureBM   As String = "BM"      'sygnatura bitmapy "BM" jako ciąg znaków
Public Const cBmpBfhSize       As Long = 14          'wielkość nagłówka BitmaFileHeader
Public Const cBmpBihSize       As Long = 40          'wielkość nagłówka BitmapInfoHeader
Public Const cBmpBfOffBits     As Long = 54          'przesunięcie do bajtów obrazu bitmapy
Public Const cBmpBitCount24    As Long = 24          'głębia kolorów - bitów na piksel
Public Const cBmpBitCount32    As Long = 32          'głębia kolorów - bitów na piksel
Public Const cBmpNotCompressed As Long = 0           'nieskompresowana bitmapa BI_RGB = 0&
Public Const cBmpMinSize       As Long = 58          'minimalny rozmiar bitmapy 24bit 14+40+4
Option Compare Database
Option Explicit

'inny, nieprzewidziany błąd
Public Const errOthUnexpected       As Long = vbObjectError + 1
'-----------------------------------------------------------------
'dolna granica zakresu numerów błędów dotyczących plików
Private Const errFileError          As Long = vbObjectError + 100
'nazwa pliku zawiera nieprawidłowe znaki
Public Const errFileBadName         As Long = errFileError + 1
'plik istnieje na dysku
Public Const errFileExist           As Long = errFileError + 3
'plik nie istnieje na dysku
Public Const errFileNotExist        As Long = errFileError + 4
'-----------------------------------------------------------------
'dolna granica zakresu numerów błędów dotyczących bitmap
Private Const errBmpError           As Long = vbObjectError + 300
'błąd formatu pliku (nieprawidłowa sygnatura pliku)
Public Const errBmpFailSignature    As Long = errBmpError + 1
'błąd formatu nagłówka BitmapInfoHeader
Public Const errBihFailFormat       As Long = errBmpError + 2
'błąd formatu nagłówka BitmapInfoHeader
Public Const errBihFailSize         As Long = errBmpError + 3
'brak nagłówka BitmapInfoHeader
Public Const errBihNotExist         As Long = errBmpError + 4
'nagłówek musi być tablicą jednowymiarową
Public Const errBihOneDimension     As Long = errBmpError + 5
'obsługiwana jest tylko 24 i 32-bitowa głębia kolorów
Public Const errBmpBitCount         As Long = errBmpError + 6
'obsługiwana jest tylko 24 głębia kolorów
Public Const errBmpOnlyBitCount24   As Long = errBmpError + 7
'obsługiwana jest tylko 24 głębia kolorów
Public Const errBmpIsCompressed     As Long = errBmpError + 8
'obsługiwana jest tylko bitmapa z 'dołu do góry'
Public Const errBmpIsTopDown        As Long = errBmpError + 9
'Plik bitmapy jest zbyt mały (min. 58 bajtów)
Public Const errBmpTooSmall         As Long = errBmpError + 10

' zwraca opis błędu własnego o numerze lErrNo
Public Function errBmpDescription(lErrNo As Long) As String
Dim sErrDscr As String
	 
	Select Case lErrNo
	'------------------------- errFileError = vbObjectError + 100
	Case errFileBadName
		sErrDscr = "Pełna nazwa pliku zawiera nieprawidłowy znak"
	Case errFileExist
		sErrDscr = "Plik docelowy istnieje."
	Case errFileNotExist
		sErrDscr = "Plik nie istnieje na dysku."
'------------------------- errBmpError = vbObjectError + 300
	Case errBmpFailSignature
		sErrDscr = "Niewłaściwa sygnatura pliku bitmapy."
	Case errBihFailFormat
		sErrDscr = "Błąd formatu nagłówka BitmapInfoHeader"
	Case errBihFailSize
		sErrDscr = "Nagłówek BitmapInfoHeader musi mieć wielkość 40 bajtów"""
	Case errBihNotExist
		sErrDscr = "Niezainicjowany nagłówek BitmapInfoHeader bitmapy."
	Case errBihOneDimension
		sErrDscr = "Nagłówek BitmapInfoHeader " & _
							 "musi być tablicą jednowymiarową."
	Case errBmpBitCount
		sErrDscr = "Obsługiwana jest tylko bitmapa" & vbNewLine & _
							 "o 24 lub 32-bitowej głębi kolorów."
	Case errBmpOnlyBitCount24
		sErrDscr = "Obsługiwana jest tylko bitmapa" & vbNewLine & _
							 "o 24-bitowej głębi kolorów."
	Case errBmpIsCompressed
		sErrDscr = "Bitmapa skompresowana nie jest obsługiwana."
	Case errBmpIsTopDown
		sErrDscr = "obsługiwana jest tylko bitmapa z 'dołu do góry'."
	Case errBmpTooSmall
		sErrDscr = "Plik jest zbyt mały." & vbNewLine & _
							 "Minimalna wielkość to " & cBmpMinSize & " bajtów"
	Case Else
		sErrDscr = "Nieprzewidziany błąd Aplikacji." & vbNewLine & _
							 "Zanotuj nr błędu i opis" & vbNewLine & _
							 "i skontaktuj się z Administratorem."
  End Select

	errBmpDescription = sErrDscr

End Function
' Public Function plikFileExist(sFullPath As String) As Boolean
' Funkcja plikFileExist (...) sprawdza, czy w lokalizacji na którą wskazuje argument sFullPath,
' będący pełna ścieżką do pliku, znajduje się wskazany plik. Funkcja pobiera położenie pierwszego
' wystąpienie znaku ':' oraz położenie ostatniego wystąpienia znaku '\' w  pełnej ścieżce
' do pliku sFullPath. Jeżeli znaki te ':' i '\' nie występują, lub gdy znak '\' znajduje się
' na końcu ścieżki funkcja kończy działanie.
' Jeżeli wszystko jest w porządku, funkcja sprawdza, począwszy od znaku po pierwszym
' wystąpieniu znaku ':', czy którykolwiek ze znaków cBadChars = ":/*?<"">|" występuje
' w pełnej ścieżce do pliku.
' Jeżeli którykolwiek nieprawidłowy znak zostaje znaleziony, funkcja generuje błąd wykonania
' informując, że w ścieżce do pliku został znaleziony nieprawidłowy znak. Następnie z pełnej
' ścieżki do pliku pobrana zostaje nazwa pliku wraz z rozszerzeniem która zostaje porównana
' z nazwą pliku jaka została zwrócona przez funkcję Dir.
  ' argumenty:
    ' sFullPath
      ' pełna ścieżka do pliku
  'zwraca:
    ' Przy powodzeniu, jeżeli plik znajduje się na dysku, zwraca TRUE. Przy niepowodzeniu,
    ' gdy plik nie został znaleziony, lub pełna ścieżka do pliku zawiera nieprawidłowy znak,
    'funkcja zwraca FALSE.
'autor: Zbigniew Bratko
'data: 04.02.2019
'
Public Function plikFileExist(sFullPath As String) As Boolean
Dim lInStr        As Long
Dim lInStrRev     As Long

Dim sFileName     As String
Dim sBadChars()   As Byte
Dim i             As Integer
Const cBadChars   As String = ":/*?<"">|"
Const cProcName   As String = "Funkcja fileNameFileFromPath(...)"
Const cAttribFile As Long = vbNormal Or vbReadOnly Or vbHidden Or vbArchive

	' pobierz położenie pierwszego wystąpienia znaku ":"
	lInStr = InStr(1, sFullPath, ":", vbBinaryCompare)
	' pobierz położenie ostatniego wystąpienia znaku "\"
	lInStrRev = InStrRev(sFullPath, "\", -1, vbBinaryCompare)

	' jeżeli nie ma znaku ";" lub "\", lub znak "\" jest na końcu ścieżki to wyjdź
	If lInStr = 0 Or lInStrRev = 0 Or lInStrRev = Len(sFullPath) Then Exit Function

	'przygotuj tablicę z kodami ASCII nieprawidłowych znaków
	sBadChars() = StrConv(cBadChars, vbFromUnicode)

	lInStr = lInStr + 1
	' sprawdzaj w pętli, od znaku po pierwszym wystąpieniu ':',
	' czy ścieżka pliku zawiera nieprawidłowy znak
	For i = LBound(sBadChars) To UBound(sBadChars)
		If InStr(lInStr, sFullPath, Chr$(sBadChars(i)), vbBinaryCompare) Then
			Err.Raise errFileBadName, cProcName, _
								"Pełna nazwa pliku zawiera nieprawidłowy znak [ " & Chr$(sBadChars(i)) & " ]."
			End If
	Next

	'wyodrębnij nazwę pliku z rozszerzeniem ze ścieżki
	sFileName = Mid$(sFullPath, lInStrRev + 1)

	' porównaj, czy funkcja Dir zwróciła taką samą nazwę pliku sFileName
	If StrComp(Dir(sFullPath, cAttribFile), sFileName, vbTextCompare) = 0 Then
		plikFileExist = True
	End If

End Function