|
| | | |
 • IV.2 GDI, HDC, bitmapa 24-bit •
- 2.1. Jak utworzyć z niczego bitmapę 24 bit i pomalować ją na czerwono ?
- 2.2. Grawerowanie siekierą, czyli prymitywny "pseudoRTF" w kontrolce Image.
- 2.3. • Kontynuacja tematu • czyli jak napisać w pseudoetykiecie tekst pionowo w kierunku od dołu do góry ?
- 2.4. Jak na formularzu udającym systemowy MsgBox umieścić ikonę odpowiadającą jednej ze stałych: vbCritical, vbQuestion, vbExclamation, vbInformation ?
- 2.5. Jak pobrać ikony z pliku i zapisać je na dysku w postaci 24 bitowych bitmap ?
- 2.6. Jak pobrać wysokość i szerokość obrazu w pliku *.jpg ?
- 2.7. Jak pobrać wysokość i szerokość obrazu w plikach .bmp, .png, .gif, .jpg ?
- 2.8 Jak pobrać systemowe bitmapy (elementy graficzne okien) ?
| | | | |
 |
| | |
|
2.1. Jak utworzyć z niczego bitmapę 24 bitową i pomalować ją na czerwono ?
Aby odpowiedzieć na to pytanie najpierw musimy zapoznać się z funkcją CreateDibSection.
' W oparciu o [Charles Petzold] "Programowanie Windows"
Oto jej składnia:
| hBitmap = CreateDibSection ( |
| | hdc, | // uchwyt kontekstu urządzenia |
| | pInfo | // wskaźnik do informacji o DIB |
| | fColorUse | //określenie rodzaju danych koloru |
| | ppBits | //wskaźnik do zmiennej wskaźnikowej |
| | hSection | // uchwyt obiektu odwzorowania pliku |
| | dwOffset) ; | // offset do bitów w obiekcie odwzorowania pliku |
Parametr hdc używany jest jedynie wówczas, gdy parametr fColorUse ma wartość DIB_PAL_COLORS. W naszym przypadku (bitmapy 24 bit) fColorUse wynosi DIB_PAL_COLORS i parametr hdc jest ignorowany, argumentom hSection i dwOffset możemy nadać wartość 0.
Zatem w swojej najprostszej postaci funkcja CreateDIBSection wymaga jedynie drugiego i czwartego argumentu. Drugi argument to wskaźnik do struktury BITMAPINFO, a czwarty jest wskaźnikiem do wskaźnika do bajtów bitmapy.
...
Oto co robi funkcja CreateDIBSection: bada strukturę BITMAPINFOHEADER i alokuje blok pamięci, który może pomieścić bity pikseli DIB. (W tym szczególnym przypadku blok ma rozmiar 384x256x3 bajtów). W parametrze ppBits, który dostarczyłeś zapisuje wskaźnik do tego bloku pamięci. Funkcja zwraca także uchwyt do bitmapy
...
Piksele bitmapy są niezainicjowane.
Ogólnie dostępna deklaracja funkcji w VB ma postać:
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hDC As Long, _
pBitmapInfo As BITMAPINFO, _
ByVal un As Long, _
ByVal lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw As Long) As Long
Niestety, dla tak zadeklarowane funkcji lplpVoid zawsze jest równy Zero. Aby uzyskać bitmapę z niczego należy użyć czwartego argumentu lplpVoid nie ByVal lecz ByRef
Ja dodatkowo (aby trochę uprościć deklarację) zamiast struktury BITMAPINFO użyłem struktury BITMAPINFOHEADER.
Ostatecznie więc (po modyfikacjach) i testach: patrz "Test CreateDIBSection (...)" funkcja CreateDIBSection dla 24 bitowej bitmapy będzie miała postać:
Private Declare Function zbCreateDIBSection Lib "gdi32" _
Alias "CreateDIBSection" _
(ByVal hDC As Long, _
pInfo As BITMAPINFOHEADER, _
ByVal fColorUse As Long, _
ppBits As Long, _
ByVal hSection As Long, _
ByVal dwOffset As Long) As Long
' zadeklarujmy dodatkowo funkcje:
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function ExtFloodFill Lib "gdi32" _
(ByVal hDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal crColor As Long, _
ByVal wFillType As Long) As Long
Private Const FLOODFILLBORDER = 0
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
' i strukturę
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 DIB_RGB_COLORS = 0
' i możemy spróbować utworzyć bitmapę z niczego w formancie imgTest
Private Sub btnTest_Click()
Dim bih As BITMAPINFOHEADER
Dim lppBits As Long
Dim lHDC As Long
Dim hBitmap As Long
Dim hBitmapOld
Dim hBrush
Dim hBrushOld
Dim aPict() As Byte
Dim lRet As Long
With bih
.biSize = 40
.biWidth = 384
.biHeight = 256
.biPlanes = 1
.biBitCount = 24
.biCompression = 0
' obliczmy wielkość naszej bitmapy w bajtach
' (z wyrównaniem do wielokrotności 4)
.biSizeImage = bih.biHeight * _
(3 * bih.biWidth + bih.biWidth Mod 4)
.biXPelsPerMeter = 0 '2952
.biYPelsPerMeter = 0 '2952
.biClrUsed = 0
.biClrImportant = 0
End With
' specjalnie stosuję tutaj wcięcia kodu, by pokazać jakie funkcje powinny być wykonywane parami tzw. metoda kanapkowa:
' np. funkcje Create(...)/Delete(...); Get(...)/Release(...) itp.
' utwórz nowy kontekst urządzenia
lHDC = CreateCompatibleDC(0)
hBitmap = zbCreateDIBSection(0&, bih, DIB_RGB_COLORS, _
lppBits, 0&, 0&)
' wybierz bitmapę w kontekście urzadzenia
hBitmapOld = SelectObject(lHDC, hBitmap)
' utwórz nowy pędzel
hBrush = CreateSolidBrush(vbRed)
' wybierz nowy pędzel
hBrushOld = SelectObject(lHDC, hBrush)
' pomaluj nowym pędzlem
Call ExtFloodFill(lHDC, 0&, 0&, vbRed, _
FLOODFILLBORDER)
' aktualizacja tablicy bajtów bitmapy
ReDim aPict(bih.biSize + bih.biSizeImage - 1)
CopyMemory aPict(0), bih, bih.biSize
CopyMemory aPict(bih.biSize), _
ByVal lppBits, bih.biSizeImage
' uaktualnij formant Image
Me.imgTest.PictureData = aPict
' wybierz stary pędzel
lRet = SelectObject(lHDC, hBrushOld)
' zniszcz nowy pędzel
lRet = DeleteObject(hBrush)
' wybierz starą bitmapę
lRet = SelectObject(lHDC, hBitmapOld)
' zniszcz nową utworzoną bitmapę
lRet = DeleteObject(hBitmap)
' zniszcz kontekst urządzenia
lRet = DeleteObject(lHDC)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.2. Grawerowanie siekierą, czyli prymitywny "pseudoRTF" w kontrolce Image.
' ZAŁOŻENIA:
- ' Mamy przykładowo 6 pól, które łączymy w jeden ciąg znaków wyświetlanych (malowanych) w formancie Image.
- ' Tekst pisany jest czcionką o jednym rozmiarze !!!
- ' Atrybuty fontów dla każdego pola zapisane są w tablicy typów tpFont(0 to 5)
- ' Pisanie po bitmapie odbywa się kontekście HDC monitora (DPI zazwyczaj 96 lub 120) więc i wydruk tekstu jest słabej jakości.
- ' Można także w trakcie pisania zmieniać rodzaj czcionki, ale należy pamiętać że wielkości bitmapy jest obliczana na początku zdarzenia Form_Current (Detail_Format).
- ' UWAGA ! Tekst pisany jest bez uwzględniania wymuszenia nowej linii w obrębie poszczególnych rekordów.
Dzięki pomocy Nguyen Bang Gianga [NBG] możliwe jest wymuszenie jednej nowej linii w obrębie rekordu !!!
- ' Przykład nazwałem zgodnie z sugestią NBG "Grawerowaniem siekierą", a poprawki można nazwać "Soleniem oceanu" ;-)
- ' Format bazy A2000+. Dla Acc'97 należy skorzystać z funkcji w module basFunction_Acc97.
ΔΔΔ | | | | |
|
|
| | |
|
2.3. • Kontynuacja tematu • czyli jak napisać w pseudoetykiecie tekst pionowo w kierunku od dołu do góry ?
Począwszy od Accessa 2000 formant Etykieta i TextBox ma właściwość Me.ctl.Vertical, ale po ustawieniu Me.ctl.Vertical = True tekst pisany jest z góry do dołu.
Dla mnie taki tekst jest słabiej czytelny od tekstu pisanego od dołu do góry i dlatego podjąłem próbę zrobienia pseudoetykietek z tekstem pisanym od dołu do góry.
W przykładzie tekst pisany jest także od góry do doły, (w celach poglądowych).
ΔΔΔ | | | | |
|
|
| | |
|
2.4. Jak na formularzu udającym systemowy MsgBox umieścić ikonę odpowiadającą jednej ze stałych: vbCritical, vbQuestion, vbExclamation, vbInformation ?
' Możemy pobrać z zasobów odpowiednią ikonę i pokazać ją jako pseudoprzezroczystą bitmapę (tzn. tło bitmapy jest koloru sekcji formularza).
' Utwórz na formularzu 4 formanty Image i nazwij je (img1, img2, img3, img4) oraz przycisk btnTest. I to wszystko ;-)
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 Declare Function DrawIcon Lib "user32" _
(ByVal hDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal hIcon As Long) As Long
Private Declare Function LoadIcon Lib "user32" _
Alias "LoadIconA" _
(ByVal hInstance As Long, _
ByVal lpIconName As Long) As Long
Private Declare Function DestroyIcon Lib "user32" _
(ByVal hIcon As Long) As Long
Private Declare Function zbCreateDIBSection Lib "gdi32" _
Alias "CreateDIBSection" _
(ByVal hDC As Long, _
pInfo As BITMAPINFOHEADER, _
ByVal fColorUse As Long, _
ppBits As Long, _
ByVal hSection As Long, _
ByVal dwOffset As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function ExtFloodFill Lib "gdi32" _
(ByVal hDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal crColor As Long, _
ByVal wFillType As Long) As Long
Private Const FLOODFILLBORDER = 0
Private Const DIB_RGB_COLORS = 0
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 Sub zbDrawIcon(img As Access.Image, _
lIDIIcon As Long, lBkgColor As Long)
Dim bih As BITMAPINFOHEADER
Dim lppBits As Long
Dim lHDC As Long
Dim hBitmap As Long
Dim hBitmapOld
Dim hBrush
Dim hBrushOld
Dim aPict() As Byte
Dim lRet As Long
Dim hIcon As Long
With bih
.biSize = 40
.biWidth = 32
.biHeight = 32
.biPlanes = 1
.biBitCount = 24
.biCompression = 0
.biSizeImage = bih.biHeight * (3 * bih.biWidth + _
bih.biWidth Mod 4)
.biXPelsPerMeter = 0 '2952
.biYPelsPerMeter = 0 '2952
.biClrUsed = 0
.biClrImportant = 0
End With
' utwórz nowy kontekst urządzenia
lHDC = CreateCompatibleDC(0)
hBitmap = zbCreateDIBSection(0&, bih, _
DIB_RGB_COLORS, lppBits, 0&, 0&)
' wybierz bitmapę w kontekście urzadzenia
hBitmapOld = SelectObject(lHDC, hBitmap)
' utwórz nowy pędzel
hBrush = CreateSolidBrush(lBkgColor)
' wybierz nowy pędzel
hBrushOld = SelectObject(lHDC, hBrush)
' pomaluj nowym pędzlem
Call ExtFloodFill(lHDC, 0&, 0&, lBkgColor, _
FLOODFILLBORDER)
hIcon = LoadIcon(0, lIDIIcon)
Call DrawIcon(lHDC, 0&, 0&, hIcon)
' zniszcz ikonę
Call DestroyIcon(hIcon)
' aktualizacja tablicy bajtów bitmapy
ReDim aPict(bih.biSize + bih.biSizeImage - 1)
CopyMemory aPict(0), bih, bih.biSize
CopyMemory aPict(bih.biSize), _
ByVal lppBits, bih.biSizeImage
' uaktualnij formant Image
img.PictureData = aPict
' wybierz stary pędzel
lRet = SelectObject(lHDC, hBrushOld)
' zniszcz nowy pędzel
lRet = DeleteObject(hBrush)
' wybierz starą bitmapę
lRet = SelectObject(lHDC, hBitmapOld)
' zniszcz nową utworzoną bitmapę
lRet = DeleteObject(hBitmap)
' zniszcz kontekst urządzenia
lRet = DeleteObject(lHDC)
End Sub
' Funkcja pomocnicza, zwraca kolor sekcji formularza, przy błędzie zwraca -1
Private Function zbGetBkgColorSection(frm As Access.Form, _
lSection As Long) As Long
Dim aRGB(0 To 3) As Byte
If lSection < 0 Or lSection > 2 Then
zbGetBkgColorSection = -1
Exit Function
End If
' kopiuj kolor do tablicy bajtów
CopyMemory aRGB(0), frm.Section(lSection).BackColor, 4
If aRGB(3) = 128 Then
' kolor sekcji określony jest jako kolor systemowy o nIndex = aRGB(0), najprawdopodobniej aRGB(0)= COLOR_BTNFACE = 15, czyli kolor przycisku
zbGetBkgColorSection = GetSysColor(aRGB(0))
Else
' kolor ustawiony przez użytkownika
zbGetBkgColorSection = frm.Section(lSection).BackColor
End If
End Function
Private Sub btnTest_Click()
Dim lBkgCol As Long
Const IDI_ERROR = 32513&
Const IDI_QUESTION = 32514&
Const IDI_EXCLAMATION = 32515&
Const IDI_INFORMATION = 32516&
lBkgCol = zbGetBkgColorSection(Me, acDetail)
Call zbDrawIcon(Me.img1, IDI_ERROR, lBkgCol)
Call zbDrawIcon(Me.img2, IDI_QUESTION, lBkgCol)
Call zbDrawIcon(Me.img3, IDI_EXCLAMATION, lBkgCol)
Call zbDrawIcon(Me.img4, IDI_INFORMATION, lBkgCol)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.5. Jak pobrać ikony z pliku i zapisać je na dysku w postaci 24 bitowych bitmap ?
Private Declare Function ExtractIcon Lib "shell32" _
Alias "ExtractIconA" _
(ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) As Long
Private Declare Function DrawIcon Lib "user32" _
(ByVal hDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal hIcon As Long) As Long
Private Declare Function DestroyIcon Lib "user32" _
(ByVal hIcon As Long) As Long
Private Declare Function zbCreateDIBSection Lib "gdi32" _
Alias "CreateDIBSection" _
(ByVal hDC As Long, _
pInfo As BITMAPINFOHEADER, _
ByVal fColorUse As Long, _
ppBits As Long, _
ByVal hSection As Long, _
ByVal dwOffset As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function FloodFill Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal crColor As Long) As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds 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 Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Const DIB_RGB_COLORS = 0
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
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
Private Const COLOR_BTNFACE = 15
Private Const MY_FILL_COLOR As Long = &HD6F2FF
Private Const MY_SIZE_BITMAPFILEHEADER As Byte = 14
' w celach poglądowych
Private aIconsPath() As String
' Pobiera ikony z pliku i zapisuje je na dysku w postaci bitmap 24 bitowych
' przy powodzeniu zwraca ciąg zerowej długości, przy błędzie zwraca opis błędu.
' • sExeFileName - pełna nazwa pliku zawierającego ikony,
' • sDestFolder - folder w którym zostaną zapisane ikony w postaci bitmap.
' • lBkgColor/ - kolor tła bitmapy
' Nazwa pliku generowana jest według następującego schematu "\~" & timeGetTime & ".bmp"
Public Function zbExtractIcon(sExeFileName As String, _
sDestFolder As String, lBkgColor As Long) As String
Dim bih As BITMAPINFOHEADER
Dim lppBits As Long
Dim lHDC As Long
Dim hBitmap As Long
Dim hBitmapOld
Dim hBrush
Dim hBrushOld
Dim aDIB() As Byte
Dim sPath As String
Dim lCountIcons As Long
Dim hIcon As Long
Dim lRet As Long
Dim i As Long
If Len(Dir(sExeFileName)) = 0 Then
zbExtractIcon = "Plik źródłowy " & sExeFileName & _
" nie istnieje !"
Exit Function
End If
' zakładam, że może być jeden znak na końcu nazwy folderu
If Right$(sDestFolder, 1) = "\" Then
sDestFolder = Left$(sDestFolder, Len(sDestFolder) - 1)
End If
If Len(Dir(sDestFolder, vbDirectory)) = 0 Or _
Right$(Dir(sDestFolder, vbDirectory), 1) = "." Then
zbExtractIcon = "Nieprawidłowa nazwa folderu docelowego " & _
sDestFolder
Exit Function
End If
' pobierz ilość ikon w pliku źródłowym
lCountIcons = ExtractIcon(Application.hWndAccessApp, _
sExeFileName, -1)
If lCountIcons = 0 Then
zbExtractIcon = "Plik źródłowy " & sExeFileName & _
" nie zawiera ikon !"
Exit Function
End If
' na wszelki wypadek, gdy zajdzie nieprzewidziany błąd
zbExtractIcon = "Nieprzewidziany błąd funkcji zbExtractIcon (...)"
' tablica ścieżek zapisanych bitmap
' (w celach poglądowych dla wizualizacji ikon)
ReDim aIconsPath(0 To lCountIcons - 1)
' zaczynamy malowanie bitmapy 24 bit o wym. 32x32 piksele
With bih
.biSize = 40
.biWidth = 32
.biHeight = 32
.biPlanes = 1
.biBitCount = 24
.biCompression = 0
.biSizeImage = bih.biHeight * (3 * bih.biWidth + _
bih.biWidth Mod 4)
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
.biClrUsed = 0
.biClrImportant = 0
End With
lHDC = CreateCompatibleDC(0&)
hBitmap = zbCreateDIBSection(0&, bih, DIB_RGB_COLORS, _
lppBits, 0&, 0&)
hBitmapOld = SelectObject(lHDC, hBitmap)
hBrush = CreateSolidBrush(lBkgColor)
hBrushOld = SelectObject(lHDC, hBrush)
' pobieraj kolejne ikony
For i = 0 To lCountIcons - 1
hIcon = ExtractIcon(Application.hWndAccessApp, _
sExeFileName, i)
' zamaluj bitmapę
lRet = FloodFill(lHDC, 0&, 0&, MY_FILL_COLOR)
lRet = DrawIcon(lHDC, 0&, 0&, hIcon)
ReDim aDIB(bih.biSize + bih.biSizeImage - 1)
CopyMemory aDIB(0), bih, bih.biSize
CopyMemory aDIB(bih.biSize), ByVal lppBits, bih.biSizeImage
lRet = DestroyIcon(hIcon)
' zapisz plik bitmapy na dysku w folderze sDestFolder
sPath = sDestFolder & "\~" & CStr(timeGetTime) & ".bmp"
If zbDibToDisk(sPath, aDIB()) <> -1 Then
aIconsPath(i) = sPath
End If
Next
lRet = SelectObject(lHDC, hBrushOld)
lRet = DeleteObject(hBrush)
lRet = SelectObject(lHDC, hBitmapOld)
lRet = DeleteObject(hBitmap)
lRet = DeleteObject(lHDC)
' chyba wszystko poszło dobrze ;-)
zbExtractIcon = ""
End Function
' 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), 40
' tylko bitmapa z nagłówkiem wielkości 40 bajtów i głębi kolorów 24 bit
If bih.biSize <> 40 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
' zwraca kolor sekcji formularza, przy błędzie zwraca -1
Private Function zbGetColorSection(lSection As Long) As Long
Dim aRGB(0 To 3) As Byte
If lSection < 0 Or lSection > 2 Then
zbGetColorSection = -1
Exit Function
End If
' kopiuj kolor do tablicy bajtów
CopyMemory aRGB(0), Me.Section(acDetail).BackColor, 4
If aRGB(3) = 128 Then
zbGetColorSection = GetSysColor(aRGB(0))
Else
' kolor ustawiony przez użytkownika
zbGetColorSection = RGB(aRGB(0), aRGB(1), aRGB(2))
End If
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sMyFolder As String
Dim sRet As String
Dim lDetailCol As Long
Dim i As Long
DoCmd.RunCommand acCmdSelectRecord
Me.btnTest.Enabled = False
'pobierz ścieżke folderu plików tymczasowych
sMyFolder = Environ$("TEMP") & "\"
' pobierz kolor sekcji Detail (pseudoprzezroczystość)
lDetailCol = zbGetColorSection(acDetail)
If lDetailCol = -1 Then
' wystąpił nieoczekiwany błąd, pobierz systemowy
' kolor COLOR_BTNFACE
lDetailCol = GetSysColor(COLOR_BTNFACE)
End If
' pobierz ikony zawarte w pliku Msaccess.exe
sRet = zbExtractIcon(SysCmd(acSysCmdAccessDir) & _
"Msaccess.exe", _
Environ$("TEMP") & "\", lDetailCol)
If Len(sRet) > 0 Then
' wystąpił błąd ponierania ikon z pliku
MsgBox sRet
Exit Sub
Else
For i = LBound(aIconsPath) To UBound(aIconsPath)
Me.imgTest.Picture = aIconsPath(i)
DoEvents
' wyczyść folder plików tymczasowych z zapisanych bitmap
Kill aIconsPath(i)
Call Sleep(250)
Next
End If
Me.btnTest.Enabled = True
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.6. Jak pobrać wysokość i szerokość obrazu w pliku *.jpg ?
Public Type JPEGinfo
Width As Integer
Height As Integer
BitsPerPixel As Integer
ColorPlanes As Integer
JPEGTYPE As Integer
End Type
' Returns True on success, False otherwise
Public Function Info_JPEG(ByVal file As String, _
JPGinfo As JPEGinfo) As Boolean
Dim FH As Integer
Dim C1 As Integer
Dim C2 As Integer
Dim Marker As Integer
Dim Length As Long
FH = FreeFile
Open file For Binary As FH
C1 = GetC(FH): C2 = GetC(FH)
If C1 = 255 And C2 = 216 Then
Do
C1 = GetC(FH)
Marker = GetC(FH)
Select Case Marker
Case 192 To 195, 197 To 207
Length = GetInt(FH)
JPGinfo.BitsPerPixel = GetC(FH)
JPGinfo.Height = GetInt(FH)
JPGinfo.Width = GetInt(FH)
JPGinfo.ColorPlanes = GetC(FH)
JPGinfo.JPEGTYPE = Marker
Info_JPEG = True
Exit Do
Case 216 To 218, -1
Exit Do
Case Else
' skip field
Length = GetInt(FH)
If Length < 2 Then Exit Do 'error
Seek #FH, Seek(FH) + Length - 2
End Select
Loop
End If
Close FH
End Function
Private Function GetC(ByVal FH As Integer) As Integer
Dim BT As String * 1
Get #FH, , BT
GetC = Asc(BT)
End Function
Private Function GetInt(ByVal FH As Integer) As Long
Dim N As Long
Dim C1 As Integer
Dim C2 As Integer
C1 = GetC(FH)
C2 = GetC(FH)
GetInt = CLng(C1) * 256 + C2
End Function
' and you would call it something like this
Private Sub Command1_Click()
Dim MyJPGInfo As JPEGinfo
Dim JPG_FilePathName As String
JPG_FilePathName = "C:\Temp\PictureName.jpg"
If Info_JPEG(JPG_FilePathName, MyJPGInfo) Then
Debug.Print MyJPGInfo.Width, MyJPGInfo.Height
End If
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.7. Jak pobrać wysokość i szerokość obrazu w plikach .bmp, .png, .gif, .jpg ?
Public Type ImageInfo
Filetype As Byte
Width As Long
Height As Long
Depth As Byte
End Type
Private Const PNG As Byte = 1
Private Const GIF As Byte = 2
Private Const JPG As Byte = 3
Private Const BMP As Byte = 4
Private Const ERROR As Byte = 255
Public Function GetImageInfo(sPath As String) As ImageInfo
On Error GoTo Handle
Dim IFileNum As Integer
Dim BTemp(2) As Byte
Dim UTemp As ImageInfo
Dim LPointer As Long
GetImageInfo.Filetype = ERROR
IFileNum = FreeFile
Open sPath For Binary As IFileNum
Get #IFileNum, 1, BTemp()
If BTemp(0) = 137 And BTemp(1) = 80 And BTemp(2) = 78 Then
UTemp = GetPng(IFileNum)
If UTemp.Filetype <> ERROR Then GetImageInfo = UTemp
End If
If BTemp(0) = 71 And BTemp(1) = 73 And BTemp(2) = 70 Then
UTemp = GetGif(IFileNum)
If UTemp.Filetype <> ERROR Then GetImageInfo = UTemp
End If
If BTemp(0) = 66 And BTemp(1) = 77 Then
UTemp = GetBmp(IFileNum)
If UTemp.Filetype <> ERROR Then GetImageInfo = UTemp
End If
If GetImageInfo.Filetype = ERROR Then
LPointer = CheckJpg(IFileNum)
If LPointer <> -1 Then
UTemp = GetJpg(IFileNum, LPointer)
If UTemp.Filetype <> ERROR Then GetImageInfo = UTemp
End If
End If
Close IFileNum
Exit Function
Handle:
GetImageInfo.Filetype = ERROR
Close IFileNum
End Function
Private Function GetPng(IFileNum As Integer) As ImageInfo
On Error GoTo Handle
Dim Msb As Byte
Dim Lsb As Byte
GetPng.Filetype = PNG
Get #IFileNum, 19, Msb
Get #IFileNum, 20, Lsb
GetPng.Width = Mult(Lsb, Msb)
Get #IFileNum, 23, Msb
Get #IFileNum, 24, Lsb
GetPng.Height = Mult(Lsb, Msb)
Get #IFileNum, 25, Msb
Get #IFileNum, 26, Lsb
Select Case Lsb
Case 0
GetPng.Depth = Msb
Case 2
GetPng.Depth = Msb * 3
Case 3
GetPng.Depth = 8
Case 4
GetPng.Depth = Msb * 2
Case 6
GetPng.Depth = Msb * 4
Case Else
GetPng.Filetype = ERROR
End Select
Exit Function
Handle:
GetPng.Filetype = ERROR
End Function
Private Function GetGif(IFileNum As Integer) As ImageInfo
On Error GoTo Handle
Dim Msb As Byte
Dim Lsb As Byte
GetGif.Filetype = GIF
Get #IFileNum, 7, Lsb
Get #IFileNum, 8, Msb
GetGif.Width = Mult(Lsb, Msb)
Get #IFileNum, 9, Lsb
Get #IFileNum, 10, Msb
GetGif.Height = Mult(Lsb, Msb)
Get #IFileNum, 11, Lsb
GetGif.Depth = (Lsb And 7) + 1
Exit Function
Handle:
GetGif.Filetype = ERROR
End Function
Private Function GetBmp(IFileNum As Integer) As ImageInfo
On Error GoTo Handle
Dim Msb As Byte
Dim Lsb As Byte
GetBmp.Filetype = BMP
Get #IFileNum, 19, Lsb
Get #IFileNum, 20, Msb
GetBmp.Width = Mult(Lsb, Msb)
Get #IFileNum, 23, Lsb
Get #IFileNum, 24, Msb
GetBmp.Height = Mult(Lsb, Msb)
Get #IFileNum, 29, Lsb
GetBmp.Depth = Lsb
Exit Function
Handle:
GetBmp.Filetype = ERROR
End Function
Private Function CheckJpg(IFileNum As Integer) As Long
On Error GoTo Handle
Dim FoundFlag As Byte
Dim BBuf(3) As Byte
Dim LPos As Long
Dim Length As Long
Length = LOF(IFileNum)
Do While LPos < Length And FoundFlag = 0
LPos = LPos + 1
Get #IFileNum, LPos, BBuf()
If BBuf(0) = 255 And BBuf(1) = 216 And BBuf(2) = 255 Then
FoundFlag = 1
CheckJpg = LPos
End If
Loop
If FoundFlag = 0 Then
CheckJpg = -1
End If
Exit Function
Handle:
CheckJpg = -1
End Function
Private Function GetJpg(IFileNum As Integer, _
LPos As Long) As ImageInfo
On Error GoTo Handle
Dim Length As Long
Dim Byt As Byte
Dim Lsb As Byte
Dim Msb As Byte
GetJpg.Filetype = JPG
Length = LOF(IFileNum)
LPos = LPos + 2
Back:
If LPos > Length Then GoTo Handle
Get #IFileNum, LPos, Byt
If Byt = 255 Then
LPos = LPos + 1
GoTo Back
End If
If Byt < 192 Or Byt > 195 Then
Get #IFileNum, LPos + 1, Msb
Get #IFileNum, LPos + 2, Lsb
LPos = LPos + Mult(Lsb, Msb) + 1
GoTo Back
End If
Get #IFileNum, LPos + 4, Msb
Get #IFileNum, LPos + 5, Lsb
GetJpg.Height = Mult(Lsb, Msb)
Get #IFileNum, LPos + 6, Msb
Get #IFileNum, LPos + 7, Lsb
GetJpg.Width = Mult(Lsb, Msb)
Get #IFileNum, LPos + 8, Lsb
GetJpg.Depth = Lsb * 8
Exit Function
Handle:
GetJpg.Filetype = ERROR
End Function
Private Function Mult(Lsb As Byte, Msb As Byte) As Long
Mult = CLng(Lsb + (Msb * 256))
End Function
przykładowe wywołanie
Private Sub btnTest_Click()
Dim iinfo As ImageInfo
iinfo = GetImageInfo("C:\TestBmp.png")
Debug.Print iinfo.Filetype, iinfo.Width, iinfo.Height
iinfo = GetImageInfo("C:\TestBmp.gif")
Debug.Print iinfo.Filetype, iinfo.Width, iinfo.Height
iinfo = GetImageInfo("C:\TestBmp.jpg")
Debug.Print iinfo.Filetype, iinfo.Width, iinfo.Height
iinfo = GetImageInfo("C:\TestBmp.jpeg")
Debug.Print iinfo.Filetype, iinfo.Width, iinfo.Height
iinfo = GetImageInfo("C:\TestBmp.bmp")
Debug.Print iinfo.Filetype, iinfo.Width, iinfo.Height
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.8 Jak pobrać systemowe bitmapy (elementy okien) ?
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 BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function LoadImage Lib "user32" _
Alias "LoadImageA" ( _
ByVal hInst As Long, _
ByVal lpszName As Any, _
ByVal uType As Long, _
ByVal cxDesired As Long, _
ByVal cyDesired As Long, _
ByVal fuLoad As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function zbCreateDIBSection Lib "gdi32" _
Alias "CreateDIBSection" _
(ByVal hDC As Long, _
pInfo As BITMAPINFOHEADER, _
ByVal fColorUse As Long, _
ppBits As Long, _
ByVal hSection As Long, _
ByVal dwOffset As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function ExtFloodFill Lib "gdi32" _
(ByVal hDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal crColor As Long, _
ByVal wFillType As Long) As Long
Private Const FLOODFILLBORDER = 0
Private Const DIB_RGB_COLORS = 0
Private Type BITMAP ' 24 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits 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 IMAGE_BITMAP = 0&
Private Const LR_DEFAULTSIZE = &H40
Private Const LR_CREATEDIBSECTION = &H2000
Private Const SRCCOPY = &HCC0020
Private Const OBM_LFARROWI = 32734
Private Const OBM_RGARROWI = 32735
Private Const OBM_DNARROWI = 32736
Private Const OBM_UPARROWI = 32737
Private Const OBM_COMBO = 32738
Private Const OBM_MNARROW = 32739
Private Const OBM_LFARROWD = 32740
Private Const OBM_RGARROWD = 32741
Private Const OBM_DNARROWD = 32742
Private Const OBM_UPARROWD = 32743
Private Const OBM_RESTORED = 32744
Private Const OBM_ZOOMD = 32745
Private Const OBM_REDUCED = 32746
Private Const OBM_RESTORE = 32747
Private Const OBM_ZOOM = 32748
Private Const OBM_REDUCE = 32749
Private Const OBM_LFARROW = 32750
Private Const OBM_RGARROW = 32751
Private Const OBM_DNARROW = 32752
Private Const OBM_UPARROW = 32753
Private Const OBM_CLOSE = 32754
Private Const OBM_BTNCORNERS = 32758
Private Const OBM_CHECKBOXES = 32759
Private Const OBM_CHECK = 32760
Private Const OBM_BTSIZE = 32761
Private Const OBM_SIZE = 32766
Private Type BMPDIMENSION
Width As Long
Height As Long
End Type
' Utwórz na formularzu 26 formantów Image i nazwij je (img1, img2,....., img26)
Private Function zbResuorceBitmap( _
Img As Access.Image, _
lIDIIcon As Long) As BMPDIMENSION
Dim bih As BITMAPINFOHEADER
Dim bmpinfo As BITMAP
Dim lppBits As Long
Dim hdcDst As Long
Dim hdcSrc As Long
Dim hBmpDIB As Long
Dim hBmpRes As Long
Dim hBmpOld As Long
Dim hBrush As Long
Dim hBrushOld As Long
Dim aPict() As Byte
Dim lRet As Long
hBmpRes = LoadImage(0&, lIDIIcon, _
IMAGE_BITMAP, 0&, 0&, _
LR_DEFAULTSIZE Or _
LR_CREATEDIBSECTION)
If hBmpRes = 0 And Err.LastDllError <> 0 Then Exit Function
lRet = GetObject(hBmpRes, Len(bmpinfo), bmpinfo)
If lRet = 0 Then Exit Function
With bih
.biSize = 40
.biWidth = bmpinfo.bmWidth
.biHeight = bmpinfo.bmHeight
.biPlanes = 1
.biBitCount = 24
.biCompression = 0
.biSizeImage = bih.biHeight * (3 * bih.biWidth + _
bih.biWidth Mod 4)
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
.biClrUsed = 0
.biClrImportant = 0
End With
' utwórz nowe konteksty urządzenia
hdcDst = CreateCompatibleDC(0)
hdcSrc = CreateCompatibleDC(0)
hBmpDIB = zbCreateDIBSection(0&, bih, _
DIB_RGB_COLORS, lppBits, 0&, 0&)
' wybierz bitmapę w kontekście urzadzenia
hBmpOld = SelectObject(hdcDst, hBmpDIB)
' utwórz nowy pędzel i pomaluj nim hdcDst
hBrush = CreateSolidBrush(vbWhite)
hBrushOld = SelectObject(hdcDst, hBrush)
Call ExtFloodFill(hdcDst, 0&, 0&, vbWhite, _
FLOODFILLBORDER)
lRet = SelectObject(hdcSrc, hBmpRes)
lRet = BitBlt(hdcDst, 0&, 0&, bih.biWidth, _
bih.biHeight, hdcSrc, 0&, 0&, SRCCOPY)
zbResuorceBitmap.Width = bih.biWidth
zbResuorceBitmap.Height = bih.biHeight
' aktualizacja tablicy bajtów bitmapy
ReDim aPict(bih.biSize + bih.biSizeImage - 1)
CopyMemory aPict(0), bih, bih.biSize
CopyMemory aPict(bih.biSize), ByVal lppBits, bih.biSizeImage
' uaktualnij formant Image
Img.PictureData = aPict()
' zniszcz niepotrzebne obiekty
lRet = SelectObject(hdcDst, hBrushOld)
lRet = DeleteObject(hBrush)
lRet = SelectObject(hdcDst, hBmpOld)
lRet = DeleteObject(hBmpDIB)
lRet = DeleteObject(hBmpRes)
lRet = DeleteDC(hdcSrc)
lRet = DeleteDC(hdcDst)
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim bdm As BMPDIMENSION
Dim aOBM(1 To 26) As Long
Dim i As Long
aOBM(1) = OBM_LFARROWI: aOBM(2) = OBM_RGARROWI
aOBM(3) = OBM_DNARROWI: aOBM(4) = OBM_UPARROWI
aOBM(5) = OBM_LFARROWD: aOBM(6) = OBM_RGARROWD
aOBM(7) = OBM_DNARROWD: aOBM(8) = OBM_UPARROWD
aOBM(9) = OBM_LFARROW: aOBM(10) = OBM_RGARROW
aOBM(11) = OBM_DNARROW: aOBM(12) = OBM_UPARROW
aOBM(13) = OBM_REDUCE: aOBM(14) = OBM_REDUCED
aOBM(15) = OBM_ZOOM: aOBM(16) = OBM_ZOOMD
aOBM(17) = OBM_RESTORE: aOBM(18) = OBM_RESTORED
aOBM(19) = OBM_COMBO: aOBM(20) = OBM_MNARROW
aOBM(21) = OBM_BTNCORNERS: aOBM(22) = OBM_CHECK
aOBM(23) = OBM_BTSIZE: aOBM(24) = OBM_SIZE
aOBM(25) = OBM_CLOSE: aOBM(26) = OBM_CHECKBOXES
For i = Lbound(aOBM) To Ubound(aOBM)
bdm = zbResuorceBitmap( _
Me.Controls("img" & _
CStr(i)), aOBM(i))
Me.Controls("img" & CStr(i)).Visible = True
Debug.Print i, bdm.Width & " x " & bdm.Height
Next
End Sub
ΔΔΔ | | | | |
|
| |
