|
| | | |
 • IV.1 Bitmapa 24 bitowa •
- 1.1 Co to jest bitmapa o głębi kolorów 24 bit ?
- 1.2 Jak pobrać rozdzielczość monitora oraz przeliczyć piksele na twipy i odwrotnie ?
- 1.3 Jak pobrać parametry bitmapy 24 bitowej osadzonej w formancie Image oraz kolor pierwszego piksela ?
- 1.4 Jak zrobić pseudoprzezroczystą 24 bitową bitmapę w formancie Image na formularzu o jednolitym kolorze, oraz pseudoprzezroczystą bitmapę w formancie CommandButton ?
- 1.5 Jak malować po bitmapie operując tylko na tablicy bajtów bitmapy, na przykładzie pseudopaska postępu na formancie CommandButton ?
- 1.6 Jak pobrać kolor i współrzędne piksela pod kursorem myszy nad bitmapą (w skali 1:1) osadzonej w formancie Image oraz jak dopasować rozmiar formantu Image do rozmiaru bitmapy ?
- 1.7 Jak przekonwertować kolorową bitmapę 24-bitową na czarno-białą ?
- 1.8 Jak pobrać składowe RGB koloru ?
- 1.9 Jak zapisać na dysk bitmapę 24 bit osadzoną w formancie Image ?
| | | | |
 |
| | |
|
1.1 Co to jest bitmapa o głębi kolorów 24 bit ?
Przy omawianiu bitmap ograniczam się tylko do 24 bitowych bitmap z nagłówkiem BITMAPINFOHEADER wielkości 40 bajtów.
Moim zdaniem na takich bitmapach bardzo łatwo (o wiele łatwiej) można operować, a oszczędności pamięci przy stosowaniu małych bitmap o mniejszej głębi kolorów nie rekompensują trudu włożonego w uwzględnie wszystkich typów bitmap i dodatkowym operowaniu na paletach kolorów bitmap.
Ponadto, przy prezentowaniu większych bitmap (tzw. obrazków) w formantach "Image" zmniejszenie głębi kolorów prowadzi do pewnego, wizualnego zafałszowania kolorów.
Więcej szczegółów o strukturze plików dowiesz się na: http://www.wotsit.org/
' W oparciu o [Charles Petzold] "Programowanie Windows"
| Private Type BITMAPFILEHEADER | ' 14-bajtowy nagłówek pliku |
| bfType As Integer | ' sygnatura BM (0x4D42) => &H424D |
| bfSize As Long | ' całkowity rozmiar pliku |
| bfReserved1 As Integer | ' równy ZERO |
| bfReserved2 As Integer | ' równy ZERO |
| bfOffBits As Long | ' przesunięcie do bitów pikseli w pliku DIB |
| End Type | |
| Private Type BITMAPINFOHEADER | ' 40-bajtowy nagłówek bitmapy |
| biSize As Long | ' rozmiar struktury |
| biWidth As Long | ' szerokość obrazu w pikselach |
| biHeight As Long | ' wysokość obrazu w pikselach (dla wartości dodatnich bitmapa jest "do góry nogami" |
| biPlanes As Integer | ' zawsze = 1 |
| biBitCount As Integer | ' bitów na piksel: 1,4,8,16,24 lub 32 |
| biCompression As Long | ' kod kompresji |
| biSizeImage As Long | ' liczba bajtów w obrazie |
| biXPelsPerMeter As Long | ' rozdzielczość pozioma pixel/metr - zazwyczj ZERO, lub 2835 (72 dpi), ew. 11811 (300 dpi) |
| biYPelsPerMeter As Long | ' rozdzielczość pionowa pixel/metr "" "" |
| biClrUsed As Long | ' liczba użytych kolorów |
| biClrImportant As Long | ' liczba kolorów znaczących, zazwyczj ZERO => wszystkie kolory są jednakowo znaczące |
| End Type | |
' • biClrUsed- dla 1-bitowych DIB = 0 lub 2
' • biClrUsed- dla 4-bitowych DIB = 0 lub 16, jeżeli 2-15 to wskazuje liczbę pozycji
' • biClrUsed- dla 8-bitowych DIB = 0 lub 256, jeżeli 2-15 to wskazuje liczbę pozycji
' • biClrUsed- dla 16, 24, 32-bitowych DIB zwykle = się ZERO
' • dla 1;4;8 - bitowych DIB używających struktury BITMAPINFOHEADER tablica
' kolorów jest strukturą RGBQUAD, a nie RGBTRIPLE.
| Private Type RGBQUAD | |
| RGBBlue As Byte | ' natężenie niebieskiego |
| RGBGreen As Byte | ' natężenie zielonego |
| RGBRed As Byte | ' natężenie czerwonego |
| rgbReserved As Byte | ' = 0 |
| End Type | |
Private Type RGBTRIPLE
rgbtBlue As Byte
rgbtGreen As Byte
rgbtRed As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type
' przykładowy odczyt struktury bitmapy "C:\Test24Bit.bmp"
' i sprawdzenie niektórych parametrów pliku *.bmp
Private Sub btnTest_Click()
Dim bfh As BITMAPFILEHEADER
Dim bih As BITMAPINFOHEADER
Dim sMsg As String
Dim ff As Integer
Const MY_BMP_PATH As String = "C:\Test24Bit.bmp"
On Error Resume Next
If Len(Dir(MY_BMP_PATH)) = 0 Then
MsgBox "Plik " & MY_BMP_PATH & " nie istnieje !"
Exit Sub
End If
ff = FreeFile
Open MY_BMP_PATH For Binary Access Read As #ff
' wczytaj nagłówek pliku
Get #ff, 1, bfh
' wczytaj nagłówek bitmapy
Get #ff, 15, bih
Close #ff
Debug.Print "BITMAPFILEHEADER"
Debug.Print "- bfType: sygnatura pliku = "; Hex$(bfh.bfType)
Debug.Print "- bfSize: rozmiar pliku = "; bfh.bfSize
Debug.Print "- bfOffBits: offset do bitów pikseli w pliku DIB = "; bfh.bfOffBits
Debug.Print "BITMAPINFOHEADER"
Debug.Print "- biSize: rozmiar struktury = "; bih.biSize
Debug.Print "- biWidth: szerokość w pikselach = "; bih.biWidth
Debug.Print "- biHeight: wysokość w pikselach = "; bih.biHeight
Debug.Print "- biPlanes: (zawsze 1) = "; bih.biPlanes
Debug.Print "- biBitCount: bitów na piksel = "; bih.biBitCount
Debug.Print "- biCompression: kod kompresji = "; bih.biCompression
Debug.Print "- biSizeImage: ilośc bajtów w obrazie = "; bih.biSizeImage
Debug.Print "- biXPelsPerMeter: poziomo pixel/metr = "; bih.biXPelsPerMeter
Debug.Print "- biYPelsPerMeter: pionowo pixel/metr = "; bih.biYPelsPerMeter
Debug.Print "- biClrUsed: liczba użytych kolorów = "; bih.biClrUsed
Debug.Print "- biClrImportant: liczba kolorów znaczących = "; bih.biClrImportant
' możemy sprawdzić, czy wczytywany plik bitmapy jest właściwy
If (bfh.bfType) <> &H4D42 Then
sMsg = sMsg & "Error - To nie jest plik bitmapy"
End If
If bih.biBitCount <> 24 Then
sMsg = sMsg & vbNewLine & _
"Error - To nie jest 24 bitowa bitmapa"
End If
If bih.biSize <> 40 Then
sMsg = sMsg & vbNewLine & _
"Error - To nie jest bitmapa z 40-to bajtowym nagłówkiem"
End If
Debug.Print String(60, "=")
If Len(sMsg) > 0 Then
Debug.Print sMsg
Else
Debug.Print "Parametry bitmapy => 'OK'"
End If
DoCmd.RunCommand acCmdDebugWindow
On Error GoTo 0
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.2 Jak pobrać rozdzielczość monitora oraz przeliczyć piksele na twipy i odwrotnie ?
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 GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
' w argumentach ByRef zwraca rozdzielczość X i Y
Private Sub zbGetDPI( _
Optional lDpiRetX As Long, _
Optional lDpiRetY As Long)
Dim hdcAcc As Long
hdcAcc = GetDC(Application.hWndAccessApp)
lDpiRetX = GetDeviceCaps(hdcAcc, LOGPIXELSX)
lDpiRetY = GetDeviceCaps(hdcAcc, LOGPIXELSY)
ReleaseDC Application.hWndAccessApp, hdcAcc
End Sub
' w argumentach ByRef zwraca przelicznik PikselX(Y) na TwipX(Y)
Private Sub zbGetPix2Twip( _
Optional snPixTwipsRetX As Single, _
Optional snPixTwipsRetY As Single)
Dim hdcAcc As Long
hdcAcc = GetDC(Application.hWndAccessApp)
snPixTwipsRetX = 1440 / GetDeviceCaps(hdcAcc, LOGPIXELSX)
snPixTwipsRetY = 1440 / GetDeviceCaps(hdcAcc, LOGPIXELSY)
ReleaseDC Application.hWndAccessApp, hdcAcc
End Sub
' w argumentach ByRef zwraca przelicznik TwipX(Y) na PikselX(Y)
Private Sub zbGetTwip2Pix( _
Optional snTwipsPixRetX As Single, _
Optional snTwipsPixRetY As Single)
Dim hdcAcc As Long
hdcAcc = GetDC(Application.hWndAccessApp)
snTwipsPixRetX = GetDeviceCaps(hdcAcc, LOGPIXELSX) / 1440
snTwipsPixRetY = GetDeviceCaps(hdcAcc, LOGPIXELSY) / 1440
ReleaseDC Application.hWndAccessApp, hdcAcc
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim lDpiX As Long, lDpiY As Long
Dim snPix2TwipX As Single, snPix2TwipY As Single
Dim snTwip2PixX As Single, snTwip2PixY As Single
' pobierz rozdzielczość ekranu
Call zbGetDPI(lDpiX, lDpiY)
Debug.Print "DPI Poziomo = "; lDpiX
Debug.Print "DPI Pionowo = "; lDpiY
' pobierz przelicznik Piksel => Twip
Call zbGetPix2Twip(snPix2TwipX, snPix2TwipY)
Debug.Print "1 PixX = "; snPix2TwipX; " twipów"
Debug.Print "1 PixY = "; snPix2TwipY; " twipów"
' pobierz przelicznik Twip => Piksel
Call zbGetTwip2Pix(snTwip2PixX, snTwip2PixY)
Debug.Print "1 TwipX = "; snTwip2PixX; " piksela"
Debug.Print "1 TwipY = "; snTwip2PixY; " piksela"
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.3 Jak pobrać parametry bitmapy 24 bitowej, osadzonej w formancie Image oraz kolor pierwszego piksela ?
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Const MY_SIZE_BIH As Long = 40
' zwraca kolor pierwszego piksela bitmapy 24-Bit formantu Image (przypadek DIB do góry nogami => osatnie trzy bajty tablicy aPict = ctl.PictureData
Private Function zbColFirstPix(ctlImg As Access.Image) As Long
Dim lBytesInLine As Long
Dim lBmpHeight As Long
Dim lOffset As Long
Dim aPict() As Byte ' tablica bajtów bitmapy
aPict() = ctlImg.PictureData
' pobierz wysokość bitmapy
CopyMemory lBmpHeight, aPict(8), 4
' bajtów na linię w bitmapie
lBytesInLine = ((UBound(aPict) - MY_SIZE_BIH + 3) \ lBmpHeight)
lOffset = lBytesInLine * (lBmpHeight - 1) + MY_SIZE_BIH
' musimy zamienić BGR (zgodne z zapisem liczby Long w tablicy aPict) na RGB
zbColFirstPix = RGB(aPict(lOffset + 2), aPict(lOffset + 1), _
aPict(lOffset))
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim bih As BITMAPINFOHEADER
Dim aPict() As Byte ' tablica bajtów bitmapy
' wczytaj DIB bitmapy
Me.imgTest.Picture = "C:/Transp24Bit.bmp"
' bitmapa 24 bit przechowywana jest w formancie Image jako tzw. upakowana DIB
' jest to nic innego jak bajty bitmapy bez pierwszych 14-tu bajtów nagłówka
' pliku (BITMAPFILEHEADER)
aPict() = Me.imgTest.PictureData
CopyMemory bih, aPict(0), MY_SIZE_BIH
' i podobnie jak w przykładzie:
Co to jest bitmapa o głębi kolorów 24 bit
Debug.Print "BITMAPINFOHEADER"
Debug.Print "- biSize: rozmiar struktury = "; bih.biSize
Debug.Print "- biWidth: szerokość w pikselach = "; bih.biWidth
Debug.Print "- biHeight: wysokość w pikselach = "; bih.biHeight
Debug.Print "- biPlanes: (zawsze 1) = "; bih.biPlanes
Debug.Print "- biBitCount: bitów na piksel = "; bih.biBitCount
Debug.Print "- biCompression: kod kompresji = "; bih.biCompression
Debug.Print "- biSizeImage: ilośc bajtów w obrazie = "; bih.biSizeImage
Debug.Print "- biXPelsPerMeter: poziomo pixel/metr = "; bih.biXPelsPerMeter
Debug.Print "- biYPelsPerMeter: pionowo pixel/metr = "; bih.biYPelsPerMeter
Debug.Print "- biClrUsed: liczba użytych kolorów = "; bih.biClrUsed
Debug.Print "- biClrImportant: liczba kolorów znaczących = "; bih.biClrImportant
' pobierz kolor pierwszego piksela bitmapy
Debug.Print " Kolor pierwszego piksela = "; zbColFirstPix(Me.imgTest)
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.4 Jak zrobić pseudoprzezroczystą 24 bitową bitmapę w formancie Image na formularzu o jednolitym kolorze, oraz pseudoprzezroczystą bitmapę w formancie CommandButton ?
' Poniższy przykład opiera się na bezpośrednim działaniu na tablicy bajtów obrazu.
' Utwórz na formularzu dwa formanty: btnTest i imgTest, powinny one zawierać 24-bitową bitmapę. Kolor pierwszego piksela będzie traktowany jako przezroczysty.
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const COLOR_BTNFACE As Long = 15
' zamienia wszystkie piksele bitmapy o kolorze 1-go piksela na kolor lNewColor
' dla fErase = True wymazuje kolorem lNewColor wszystkie piksele bitmapy
Private Sub zbPseudoTranspBMP( _
ctl As Access.Control, lNewColor As Long, _
Optional fErase As Boolean = False)
On Error GoTo ErrHandler
| Dim lBih_Size As Long | ' wielkość BitmapInfoHeader |
| Dim lBitCount As Integer | ' bitów na piksel |
| Dim lBmpLine As Long | ' linia odniesienia |
| Dim lBmpOffset As Long | ' przesunięcie bajtów |
| Dim lFirstPixCol As Long | ' kolor pierwszego piksela |
| Dim lBGRBgkCol As Long | ' kolor tła (BGR) |
| Dim lColPixTmp As Long | ' bieżący kolor piksela |
| Dim lBmpWidth As Long | ' szerokość bitmapy |
| Dim lBmpHeight As Long | ' wysokość bitmapy |
| Dim lBmpLenLine As Long | ' ilość bajtów w linii bitmapy |
| Dim Y As Long | ' licznik linii |
| Dim X As Long | ' licznik pikseli w linii |
| Dim aPict() As Byte | ' tablica DIB bajtów bitmapy |
' sprawdź typ formantu
If ctl.ControlType = acImage Or _
ctl.ControlType = acCommandButton Then
' sprawdź, czy formant zawiera bitmapę
If Not (IsArray(ctl.PictureData)) Then Exit Sub
aPict = ctl.PictureData
' wielkość BitmapInfoHeader - musi być = 40
CopyMemory lBih_Size, aPict(0), 4
If lBih_Size <> 40 Then Exit Sub
' szerokość bitmapy
CopyMemory lBmpWidth, aPict(4), 4
' wysokość bitmapy
CopyMemory lBmpHeight, aPict(8), 4
' bitów na piksel - musi być = 24
CopyMemory lBitCount, aPict(14), 2
If lBitCount <> 24 Then Exit Sub
' bajtów na linię w bitmapie
lBmpLenLine = (UBound(aPict()) - lBih_Size + 3) \ lBmpHeight
' kolor pierwszego piksela
CopyMemory lFirstPixCol, _
aPict(lBmpLenLine * (lBmpHeight - 1) + _
lBih_Size), 3
lBGRBgkCol = zbRgbToBgr(lNewColor)
' przejdź po wszystkich liniach
For Y = 0 To (lBmpHeight - 1)
lBmpLine = lBmpHeight - Y - 1
' przejdź po wszystkich pikselach w linii i zamień kolory
For X = 0 To (lBmpWidth - 1)
lBmpOffset = 3 * X + lBmpLine * lBmpLenLine + lBih_Size
CopyMemory lColPixTmp, aPict(lBmpOffset), 3
If fErase Then
' monochromatyczna bitmapa
CopyMemory aPict(lBmpOffset), lBGRBgkCol, 3
Else
If lColPixTmp = lFirstPixCol Then
' pseudoprzezroczysta bitmapa
CopyMemory aPict(lBmpOffset), lBGRBgkCol, 3
End If
End If
Next
Next
ctl.PictureData = aPict
End If
ExitHere:
Exit Sub
ErrHandler:
MsgBox "Błąd nr: " & Err.Number & _
" Procedura zbPseudoTranspBMP() " & _
vbNewLine & Err.Description
Resume ExitHere
End Sub
' konwertuje kolor z RGB na BGR - na potrzeby CopyMemory
Private Function zbRgbToBgr(lMyCol As Long) As Long
Dim aRGB(0 To 3) As Byte
CopyMemory aRGB(0), lMyCol, 3
aRGB(3) = aRGB(0): aRGB(0) = aRGB(2): aRGB(2) = aRGB(3)
CopyMemory zbRgbToBgr, aRGB(0), 3
End Function
' zwraca kolor sekcji formularza, przy błędzie zwraca -1
Private Function zbGetBkgColorForm(lSection As Long) As Long
Dim aRGB(0 To 3) As Byte
If lSection < 0 Or lSection > 2 Then
zbGetBkgColorForm = -1
Exit Function
End If
' kopiuj kolor do tablicy bajtów
CopyMemory aRGB(0), Me.Section(lSection).BackColor, 4
If aRGB(3) = 128 Then ' If aRGB(3) <> 0 Then
' kolor sekcji określony jest jako kolor systemowy o nIndex = aRGB(0), najprawdopodobniej aRGB(0)= COLOR_BTNFACE = 15, czyli kolor przycisku
zbGetBkgColorForm = GetSysColor(aRGB(0))
Else
' kolor ustawiony przez użytkownika
zbGetBkgColorForm = Me.Section(lSection).BackColor
End If
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim lColNew As Long
' pobierz kolor tła przycisku
lColNew = GetSysColor(COLOR_BTNFACE)
Call zbPseudoTranspBMP(Me.btnTest, lColNew, False)
' pobierz kolor tła sekcji Szczegóły
lColNew = zbGetBkgColorForm(acDetail)
Call zbPseudoTranspBMP(Me.imgTest, lColNew, False)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.5 Jak malować po bitmapie operując tylko na tablicy bajtów bitmapy, na przykładzie pseudopaska postępu na formancie CommandButton ?
Przykład ten opiera się na metodzie bezpośredniego działania na tablicy bajtów obrazu i korzysta z funkcji opisanych powyżej
ΔΔΔ | | | | |
|
|
| | |
|
1.6 Jak pobrać kolor i współrzędne piksela pod kursorem myszy nad bitmapą (w skali 1:1) osadzonej w formancie Image oraz jak dopasować rozmiar formantu Image do rozmiaru bitmapy ?
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
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 GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Type MY_BMP_INFO
biSize As Long
biWidth As Long
biHeight As Long
End Type
Private bih As MY_BMP_INFO
Private snPix2TwipX As Single
Private snPix2TwipY As Single
Private snTwip2PixX As Single
Private snTwip2PixY As Single
Private lSizeLine As Long
Private aPict() As Byte
Private Sub Form_Load()
' pobierz przeliczniki Pix<=>Twip
zbGetPix2Twip snPix2TwipX, snPix2TwipY
zbGetTwip2Pix snTwip2PixX, snTwip2PixY
Me.imgTest.SizeMode = acOLESizeClip
Me.imgTest.PictureAlignment = 0
' zapamiętaj DIB bitmapy
aPict = Me.imgTest.PictureData
' i skopiuj 12 bajtów nagłówka
CopyMemory bih, aPict(0), 12
Me.imgTest.Width = CLng(snPix2TwipX * bih.biWidth)
Me.imgTest.Height = CLng(snPix2TwipY * bih.biHeight)
' oblicz ilość bajtów na linię w bitmapie
lSizeLine = (3 * bih.biWidth + bih.biWidth Mod 4)
' lSizeLine = (UBound(aPict) - bih.biSize) / bih.biHeight
End Sub
' odczytuje na bieżąco kolor i współrzędne piksela pod kursorem myszy
Private Sub imgTest_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, Y As Single)
Dim aBGR(0 To 2) As Byte
Dim lColPix As Long
Dim lOffset As Long
X = snTwip2PixX * X
Y = snTwip2PixY * Y
X = (CLng(X * snPix2TwipX) * bih.biWidth) / Me.imgTest.Width
Y = (CLng(Y * snPix2TwipY) * bih.biHeight) / Me.imgTest.Height
' nie przekrocz wymiarów formantu
If X < 0 Then X = 0
If X > bih.biWidth - 1 Then X = bih.biWidth - 1
If Y < 0 Then Y = 0
If Y > bih.biHeight - 1 Then Y = bih.biHeight - 1
lOffset = (3 * X) + (bih.biHeight - Y - 1) * lSizeLine + bih.biSize
CopyMemory aBGR(0), aPict(lOffset), 3
CopyMemory lColPix, aBGR(0), 3
Me.Caption = "X: " & CLng(X + 1) & " Y: " & CLng(Y + 1) & _
" R=" & aBGR(2) & " G=" & aBGR(1) & " B=" & aBGR(0)
End Sub
' w argumentach ByRef zwraca przelicznik PikselX(Y) na TwipX(Y)
Private Sub zbGetPix2Twip( _
Optional snPixTwipsRetX As Single, _
Optional snPixTwipsRetY As Single)
Dim hdcAcc As Long
hdcAcc = GetDC(Application.hWndAccessApp)
snPixTwipsRetX = 1440 / GetDeviceCaps(hdcAcc, LOGPIXELSX)
snPixTwipsRetY = 1440 / GetDeviceCaps(hdcAcc, LOGPIXELSY)
ReleaseDC Application.hWndAccessApp, hdcAcc
End Sub
' w argumentach ByRef zwraca przelicznik TwipX(Y) na PikselX(Y)
Private Sub zbGetTwip2Pix( _
Optional snTwipsPixRetX As Single, _
Optional snTwipsPixRetY As Single)
Dim hdcAcc As Long
hdcAcc = GetDC(Application.hWndAccessApp)
snTwipsPixRetX = GetDeviceCaps(hdcAcc, LOGPIXELSX) / 1440
snTwipsPixRetY = GetDeviceCaps(hdcAcc, LOGPIXELSY) / 1440
ReleaseDC Application.hWndAccessApp, hdcAcc
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.7 Jak przekonwertować kolorową bitmapę 24-bitową na czarno-białą ?
Na tym przykładzie kończę przedstawianie możliwości bezpośredniego działania na bajtach bitmapy, ponieważ metoda taka (za wyjątkiem pseudoprzezroczystości) wymaga wiele trudu, a narysowanie dowolnych elementów graficznych graniczy z cudem ;-)
Dlatego też na następnej stronie przedstawiam operacje graficzne jakie można wykonać na bitmapie operując na niej w kontekście urządzenia HDC przy pomocy funkcji GDI.
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Type MY_BMP_INFO
biSize As Long
biWidth As Long
biHeight As Long
End Type
Private MyBih As MY_BMP_INFO
' konwertuje 24-bitową bitmapę na skalę szarości
' pobiera wspólczynniki konwersji poszczególnych składowych RGB
Private Sub zbRGB2GrayScale(img As Access.Image, _
snRedToGray As Single, _
snGreenToGray As Single, _
snBlueToGray As Single)
Dim lLenLine As Long
Dim lBpmLineRef As Long
Dim lOffset As Long
Dim lColGray As Byte
Dim lNorm As Long
Dim Y As Long
Dim X As Long
Dim aPict() As Byte
' sprawdź poprawność współczynników konwersji kolorów
lNorm = CLng(snRedToGray + snGreenToGray + snBlueToGray)
If lNorm < 0 Or lNorm > 1 Then
MsgBox "Nieprawidłowe wartości" & _
"współczynników konwersji kolorów !"
Exit Sub
End If
' zapamiętaj DIB bitmapy
aPict = img.PictureData
' i skopiuj 12 bajtów nagłówka
CopyMemory MyBih, aPict(0), 12
lLenLine = (3 * MyBih.biWidth + MyBih.biWidth Mod 4)
For Y = 0 To (MyBih.biHeight - 1)
lBpmLineRef = MyBih.biHeight - Y - 1
For X = 0 To (MyBih.biWidth - 1)
lOffset = 3 * X + lBpmLineRef * lLenLine + MyBih.biSize
lColGray = snRedToGray * aPict(lOffset + 2) + _
snGreenToGray * aPict(lOffset + 1) + _
snBlueToGray * aPict(lOffset)
aPict(lOffset + 2) = lColGray
aPict(lOffset + 1) = lColGray
aPict(lOffset + 0) = lColGray
Next
Next
img.PictureData = aPict()
Erase aPict()
DoEvents
End Sub
' przykładowe wywołanie
Private Sub btnTest_Click()
Dim aPictOryg() As Byte
' zapamiętaj DIB bitmapy
aPictOryg = Me.imgTest.PictureData
' wariant 1 (każdy kolor jest równorzędny)
Me.imgTest.PictureData = aPictOryg
Me.lblTest.Caption = "R=0.333 G=0.333 B=0.333"
Call zbRGB2GrayScale(Me.imgTest, 0.33333, 0.33333, 0.33333)
DoEvents: Sleep 3000
' wariant 2 (wizualny odbiór jasności składowych)
Me.imgTest.PictureData = aPictOryg
Me.lblTest.Caption = "R=0.2125 G=0.7154 B=0.0721"
Call zbRGB2GrayScale(Me.imgTest, 0.2125, 0.7154, 0.0721)
DoEvents: Sleep 3000
' wariant 3 => inny używany standard (nie jestem pewien, być może Adobe ?)
Me.imgTest.PictureData = aPictOryg
Me.lblTest.Caption = "R=0.299 G=0.587 B=0.114"
Call zbRGB2GrayScale(Me.imgTest, 0.299, 0.587, 0.114)
DoEvents: Sleep 3000
' pokaż oryginał
Me.imgTest.PictureData = aPictOryg
Me.lblTest.Caption = "Koniec testu"
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.8 Jak pobrać składowe RGB koloru ?
grupa: pl.comp.bazy-danych.msaccess
wątek: Odwrotna do RGB
przedstawił: Piotr Lipski i Zbigniew Bratko
' • Metoda I
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
' jeżeli kolor wejściowy jest identyfikowany jako kolor systemowy, to funkcja zwraca kolor systemowy, w przeciwnym razie kolor wejściowy, w argumentach ByRef funkcja zwraca składowe RGB koloru wejściowego,
Public Function zbColorToRGB(ByVal lColor As Long, _
Optional bRedRet As Byte, _
Optional bGreenRet As Byte, _
Optional bBlueRet As Byte) As Long
Dim lColTmp As Long
Dim aRGB(0 To 3) As Byte
' kopiuj kolor do tablicy bajtów
CopyMemory aRGB(0), lColor, 4
If aRGB(3) = 128 Then
' może to być kolor systemowy o nIndex = aRGB(0)
lColor = GetSysColor(aRGB(0))
CopyMemory aRGB(0), lColor, 4
End If
bRedRet = aRGB(0): bGreenRet = aRGB(1): bBlueRet = aRGB(2)
zbColorToRGB = lColor
End Function
' • Metoda II - trochę przerobiona procedura Piotra Lipskiego: Sub testrgb ()
Private Sub plTestRGB(lColor As Long)
Dim lngRGB As Long
Dim lngR As Long, lngG As Long, lngB As Long
Rem lngRGB = RGB(23, 34, 45)
lngRGB = lColor
lngR = lngRGB Mod 256
lngRGB = lngRGB \ 256
lngG = lngRGB Mod 256
lngRGB = lngRGB \ 256
lngB = lngRGB Mod 256
Debug.Print "pl ", lColor, "R=" & lngR; "; G=" & lngG; "; B=" & lngB
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim bRed As Byte, bGreen As Byte, bBlue As Byte
Dim lMyColor As Long
lMyColor = RGB(123, 234, 210)
lMyColor = zbColorToRGB(lMyColor, bRed, bGreen, bBlue)
Debug.Print "zb ", lMyColor, _
"R=" & bRed; "; G=" & bGreen; "; B=" & bBlue
' -2147483633 <= domyślny kolor sekcji Szczegóły
lMyColor = zbColorToRGB(-2147483633, bRed, bGreen, bBlue)
Debug.Print "zb ", lMyColor, _
"R=" & bRed; "; G=" & bGreen; "; B=" & bBlue
Call plTestRGB(RGB(123, 234, 210))
Call plTestRGB(-2147483633)
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.9 Jak zapisać na dysk bitmapę 24 bit osadzoną w formancie Image ?
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Const MY_SIZE_BITMAPFILEHEADER As Long = 14
Private Const MY_SIZE_BITMAPINFOHEADER As Long = 40
' Jeżeli aDIBBytes() nie jest bitmapą o nagłówku wielkości 40 bajów i 24-bitowej głębi kolorów funkcja zwraca -1. Przy powodzeniu (bih.biSize = 40 i bih.biBitCount = 24) funkcja zwraca 0
Private Function zbDibToDisk( _
sDestFullPath As String, _
aDIBBytes() As Byte) As Long
Dim bfh As BITMAPFILEHEADER
Dim bih As BITMAPINFOHEADER
Dim aBytesBMP() As Byte
Dim ff As Long
' kopiuj BitmapInfoHeader do struktury bih
CopyMemory bih, aDIBBytes(0), MY_SIZE_BITMAPINFOHEADER
' tylko bitmapa z nagłówkiem wielkości 40 bajtów i głębi kolorów 24-bit
If bih.biSize <> MY_SIZE_BITMAPINFOHEADER Or _
bih.biBitCount <> 24 Then
zbDibToDisk = -1
Exit Function
End If
' Rozmiar tablicy bajtów 24-bitowej bitmapy (pliku do zapisu na dysk)
ReDim aBytesBMP(0 To UBound(aDIBBytes) + _
MY_SIZE_BITMAPFILEHEADER)
' Start BitmapFileHeader
' sygnatura pliku bitmapy
bfh.bfType = &H4D42
CopyMemory aBytesBMP(0), bfh.bfType, 2
' wielkość pliku bitmapy
bfh.bfSize = CLng(UBound(aDIBBytes) + MY_SIZE_BITMAPFILEHEADER + 1)
CopyMemory aBytesBMP(2), bfh.bfSize, 4
' rezerwa_1
bfh.bfReserved1 = 0
CopyMemory aBytesBMP(6), bfh.bfReserved1, 2
' rezerwa_2
bfh.bfReserved2 = 0
CopyMemory aBytesBMP(8), bfh.bfReserved2, 2
' przesunięcie do bitów bitmapy
bfh.bfOffBits = CLng(bfh.bfSize - bih.biSizeImage)
CopyMemory aBytesBMP(10), bfh.bfOffBits, 4
' Koniec BitmapFileHeader
' kopiuj DIB bitmapy do aBytesBMP
CopyMemory aBytesBMP(14), aDIBBytes(0), _
UBound(aDIBBytes) + 1
ff = FreeFile
' zapisz na dysk
Open sDestFullPath For Binary Access Write As #ff
Put #ff, , aBytesBMP()
Close #ff
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sFileDest As String
' zapisz DIB do folderu plików tymczasowych (jeżeli plik istnieje to go usuń)
sFileDest = Environ$("TEMP") & "\~Dib2Bmp.bmp"
If Len(Dir(sFileDest)) > 0 Then Kill (sFileDest)
If zbDibToDisk(sFileDest, Me.imgTest.PictureData) = -1 Then
MsgBox "Niepowodzenie", vbExclamation
End If
End Sub
ΔΔΔ | | | | |
|
| |
