Public Function bmpPictureStorageFormat( _
              Optional lPictStorageFormat As Long _
                       = cPrpStorageNotChange) As Long
Dim dbs            As DAO.Database
Dim prp            As DAO.Property
Dim lStorageFormat As Long
Dim lErrNumber     As Long
Dim strErrDscription  As String
Const cProcName       As String = "Funkcja bmpPictureStorageFormat(...)"


	' ustaw domyślną zwracaną wartość
	bmpPictureStorageFormat = cPrpStorageUnknown

	'sprawdź poprawność argumentu: <= 1
	If lPictStorageFormat > cPrpStorageConvert Then
		Err.Raise errArgFailValue, cProcName, _
							errBmpDescription(errArgFailValue)
	End If

	'sprawdź wersję MS Access
	If vbaVersionAccess < cAccVersion2007 Then
		'Access jest w wersji 2003 lub niższej, (właściwość nie występuje)
		bmpPictureStorageFormat = cPrpStorageNotFound
		Exit Function
	End If

	Set dbs = CurrentDb
		With dbs
			On Error Resume Next
				' ponieważ właściwość może być nieustawiona, włącz pułapkowanie błędu
				' i spróbuj pobrać format przechowywania obrazów
				lStorageFormat = .Properties(cPrpStoragePictureName)
				If Err.Number = 0 Then
					'właściwość jest ustawiona, zapisz wartość
					bmpPictureStorageFormat = lStorageFormat
					If lPictStorageFormat >= 0 Then
						' ustaw właściwość, jeżeli wartość jest inna niż przekazana
						If lPictStorageFormat <> lStorageFormat Then
							.Properties(cPrpStoragePictureName) = lPictStorageFormat
							' zwróć wartość właściwości
							bmpPictureStorageFormat = .Properties(cPrpStoragePictureName)
						End If
					End If
				Else
					' właściwość nie jest ustawiona
					If Err.Number = cAccPrpNotFound Then
						' i nie jest wymagana zmiana, zwróć brak
						' właściwości cPrpStorageNotFound = (-1)
						If lPictStorageFormat < 0 Then
							bmpPictureStorageFormat = cPrpStorageNotFound
						Else
							'utwórz właściwość i przypisz jej wartość
							Set prp = .CreateProperty( _
								cPrpStoragePictureName, _
										dbLong, lPictStorageFormat)
										.Properties.Append prp
								.Properties.Refresh
								bmpPictureStorageFormat = .Properties(cPrpStoragePictureName)
							Set prp = Nothing
						End If
					Else
						'nieprzewidziany błąd, włącz obsługę błędów i wygeneruj błąd
						On Error GoTo 0
						Err.Raise Err.Number, cProcName, Err.Description
					End If
				End If
			On Error GoTo 0
		End With
	Set dbs = Nothing

End Function

Option Compare Database
Option Explicit

Public Const cAccVersion2007   As Long = 12          'numer wersji MS Access 2007
'+-----------------------------------------------+
'|              Const - Bitmap                   |
'+-----------------------------------------------+
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 cBmpOffsetToBits  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)
Public Const cBmpDIBMinSize    As Long = 44          'minimalny rozmiar DIB bitmapy 24bit (40+4)

'+-----------------------------------------------+
'| Const - PictureStorageFormat MS Access 2007+  |
'+-----------------------------------------------+
' nr błędu "Nie odnaleziono właściwości"
Public Const cAccPrpNotFound        As Long = 3270
' Nazwa właściwości "Format przechowywania właściwości obrazów"
Public Const cPrpStoragePictureName As String = "Picture Property Storage Format"
' Zachowaj format obrazu źródłowego, domyślnie dla nowej bazy w formacie .accdb
Public Const cPrpStoragePreserve    As Long = 0
' Konwertuj wszystkie dane obrazu na mapy bitowe
Public Const cPrpStorageConvert     As Long = 1
' przy tworzeniu nowej bazy MS Access 2007+ w starszym formacie .mdb,
' opcja jest zaznaczona jako 1, ale właściwość ta nie jest ustawiona,
' zgłaszany jest błąd nr 3270 "Nie odnaleziono właściwości"
Public Const cPrpStorageNotFound    As Long = -1
' tylko odczyt właściwości
Public Const cPrpStorageNotChange   As Long = -2
' nieprzewidziany błąd
Public Const cPrpStorageUnknown     As Long = -3

Option Compare Database
Option Explicit
'+---------------------------------------------+
'| Errors - własna obsługa niektórych błędów   |
'+---------------------------------------------+
'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 argumentów funkcji
Private Const errArgsError          As Long = vbObjectError + 200
'argument musi być tablicą
Public Const errArgIsNotArray       As Long = errArgsError + 1
'tablica jest niezainicjowana
Public Const errArrayNotInitialized As Long = errArgsError + 2
'nieprawidłowa wartość argumentu
Public Const errArgFailValue        As Long = errArgsError + 3
'--------------------------------------------------------------------
'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
'PictureData: DIB jest zbyt mały (min. 44 bajty)
Public Const errBmpDibTooSmall      As Long = errBmpError + 11

'--------------------------------------------------------------------
'dolna granica zakresu numerów błędów dotyczących Właściwości
Private Const errPrpError           As Long = vbObjectError + 1000
'nie można ustawić właściwości „Picture Property Storage Format”
'(Format przechowywania właściwości obrazów)
Public Const errPropertyStorage     As Long = errPrpError + 1
'nieoczekiwany błąd ustawienia właściwości Format przechowywania
'właściwości obrazów (Picture Property Storage Format)"
Public Const errPropertyStorageFail As Long = errPrpError + 2


' 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."
	'------------------------- errArgsError = vbObjectError + 200
	Case errArgIsNotArray
		 sErrDscr = "Argumentem funkcji musi być tablicą."
	Case errArrayNotInitialized
		 sErrDscr = "Tablica nie jest zainicjowana."
	Case errArgFailValue
		 sErrDscr = "Nieprawidłowa wartość argumentu."
	'------------------------- 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 bitmapy jest zbyt mały." & vbNewLine & _
								 "Minimalna wielkość to " & cBmpMinSize & " bajtów."
		Case errBmpDibTooSmall
			sErrDscr = "Tablica Image.PictureData" & vbNewLine & _
								 "musi zawierać minimum " & cBmpDIBMinSize & " 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 vbaVersionAccess() As Integer
' Wykorzystując funkcję SysCmd z argumentem acSysCmdAccessVer pobiera do zmiennej
' typu Variant wersję programu MS Access i konwertuje zwracaną wartość na typ Integer.
'   argumenty:
'     nie pobiera argumentów
'   zwraca:
'     Przy powodzeniu zwraca nr wersji MS Access. Przy niepowodzeniu zwraca ZERO.
' autor: Zbigniew Bratko
' data: 08.02.2019

Public Function vbaVersionAccess() As Integer
Dim varVersion As Variant
 
	varVersion = Nz(Application.SysCmd(acSysCmdAccessVer), 0)
	If IsNumeric(varVersion) Then
		vbaVersionAccess = CInt(varVersion)
	Else
		vbaVersionAccess = Val(varVersion)
	End If

End Function