Tekst informacyjny o polityce Cookies Close   
    
 
         
• Strona główna
• 1. Linki
• 3. Kontakt: e-Mail
 
         
• 1. Baza danych
• 2. Tabele i kwerendy
• 3. Formularze
• 4. Raporty
• 5. Moduły i makra
• 6. Obsługa błędów
 
    

II.   VBA 

    
• 1. Okna Accessa
• 2. Okna Formularzy
• 3.Okna Dialogowe
• 4. Tekst
• 5. Liczby
• 6. Pliki
• 7. Inne
 
    

III.   API 

    
• 1. Ogólnie o API
• 2. Funkcje API
• 3. System
• 4. Praca z oknami
• 5. Okna dialogowe
• 6. API - Inne
 
         
• 1. Bitmapy 24 Bit
• 2. GDI i HDC
• 3. Kody kreskowe
• 4. Formant Image
• 5. FreeImage.dll
 
    

V.   Inne 

    
• 1. Shell i MsDOS
• 2. Kontrolki
• 3. ६ԼҚ ਸ
• 4. Unikod

 
Odwiedzin:

Logo AccessFAQ• 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 ?


   Przykład:  • bmp30a_04  •  52 KB  •  status: FREE  Pobrano    razy   


' 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


   Przykład:  • bmp30a_05  •  52 KB  •  status: FREE  Pobrano    razy   


 ΔΔΔ 

 

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 ?


   Przykład:  • bmp30a_06  •  52 KB  •  status: FREE  Pobrano    razy   


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łą ?


   Przykład:  • bmp30a_07  •  52 KB  •  status: FREE  Pobrano    razy   


    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

 ΔΔΔ