Problem with loading a 256 color bitmap (using the hard way)

[Paulo]

Hi to all,

I canŽt understand the problem with this function. Running in the VB IDE it
does not work but could not detect what is wrong. When compiled an error is
prodused and the application terminates.

Can anyone of you gurus help me with this?

TIA
Paulo Costa

' THE FUNCTION:

Public Function Load_BMP256( _
FileName As String _
) As IPictureDisp
' -------------------------------------------------------------------
' Declare procedure level variables:
Dim str_FileName As String
Dim int_FileNumber As Integer
Dim udt_BMP_FH As BITMAPFILEHEADER
Dim udt_BMP_I As BITMAPINFO
Dim int_PixSize As Integer ' Number of bytes used by each pixel data
Dim lng_ScanLineSize As Long ' Size in bytes of each scanline
Dim byt_ColorData() As Byte
Dim byt_PixelData() As Byte
Dim lng_ScrDC As Long
Dim lng_PicDC As Long
Dim lng_hBmp As Long
Dim lng_PrevBmp As Long
Dim lng_hPal As Long
Dim lng_hPrevPal As Long
Dim lng_Width As Long
Dim lng_Height As Long
Dim udt_Pal As LOGPALETTE
Dim udt_Pic As PICTDESC
Dim udt_PicGUID As GUID
Dim lng_Res As Long
Dim obj_Pic As IPicture
' -------------------------------------------------------------------
' Establish an error directive at procedure level:
On Error GoTo Err_Handler
' -------------------------------------------------------------------
' 1) Open the file, check if valid, and get data.
' Check if file exists:
str_FileName$ = Trim$(FileName$)
If Len(Dir$(str_FileName$)) = 0 Then
Err.Raise 53& ' File not found (Error 53)
End If
int_FileNumber% = FreeFile%
Open str_FileName$ For Binary Access Read Lock Write As #int_FileNumber%
Get #int_FileNumber%, , udt_BMP_FH
' Check for the file type signature 'BM':
If udt_BMP_FH.bfType% <> BMP_FileSignature% Then
Close #int_FileNumber%
Err.Raise 321& 'Invalid file format (Error 321)
End If
' Confirm file size:
If udt_BMP_FH.bfSize& <> FileLen&(str_FileName$) Then
Close #int_FileNumber%
Err.Raise 321& 'Invalid file format (Error 321)
End If
' Redim different buffers and get info header and colors:
ReDim udt_BMP_I.bmiColors(0 To 255)
Get #int_FileNumber%, Len(udt_BMP_FH) + 1, udt_BMP_I
' Check for valid bits per pixel values:
Select Case udt_BMP_I.bmiHeader.biBitCount%
Case Is = 1, Is = 4, Is = 16, Is = 24, Is = 32
Close int_FileNumber%
With Err
.Description$ = "The application does not support " _
& udt_BMP_I.bmiHeader.biBitCount% & "-bit bitmaps"
.Raise vbObjectError& + 1& 'Invalid file format (Error 321)
End With
Case Is = 8
' This means this file is valid.
Case Else
Close int_FileNumber%
Err.Raise 321& 'Invalid file format (Error 321)
End Select
' Get color data:
ReDim byt_ColorData(0 To 1023)
Get #int_FileNumber%, Len(udt_BMP_FH) + Len(udt_BMP_I.bmiHeader) + 1,
byt_ColorData
' Because each scanline is padded for DWORD chunks it will be DWORD
' aligned. So let's calculate the length of the scanlines:
With udt_BMP_I.bmiHeader
int_PixSize% = .biBitCount% / 8
lng_Width& = .biWidth&
lng_Height& = .biHeight&
End With
lng_ScanLineSize& = lng_Width& * int_PixSize%
lng_ScanLineSize& = IIf(lng_ScanLineSize& Mod 4& = 0&, _
lng_ScanLineSize&, _
lng_ScanLineSize& + 4& - (lng_ScanLineSize& Mod 4&))
' Scale the byte array that will receive the DIB color data:
ReDim byt_PixelData(1& To lng_ScanLineSize&, 1& To lng_Height&) As Byte
Get #int_FileNumber%, udt_BMP_FH.bfOffBits + 1, byt_PixelData
Close int_FileNumber%
' -------------------------------------------------------------------
' 2) Set the bitmap image.
' Get the handle to the desktop DC:
lng_ScrDC& = GetDC&(GetDesktopWindow&())
' Create a DC to work with:
lng_PicDC& = CreateCompatibleDC&(lng_ScrDC&)
' Create a bitmap:
lng_hBmp& = CreateCompatibleBitmap&(lng_ScrDC&, lng_Width&, lng_Height&)
lng_PrevBmp& = SelectObject&(lng_PicDC&, lng_hBmp&)
' Set the bitmap bits:
Call SetDIBits&(lng_PicDC&, lng_hBmp&, 0&, lng_Height&, _
byt_PixelData(1&, 1&), udt_BMP_I, DIB_RGB_COLORS)
' -------------------------------------------------------------------
' 3) Set the bitmap palette.
' Initialize the palette:
With udt_Pal
.palVersion% = &H300
.palNumEntries% = 256
CopyMemory VarPtr&(.palPalEntry(0)), VarPtr&(byt_ColorData(0)), 1024&
End With
' Create the palette and put it to work:
lng_hPal& = CreatePalette&(udt_Pal)
lng_hPrevPal& = SelectPalette&(lng_PicDC&, lng_hPal&, 0&)
Call RealizePalette&(lng_PicDC&)
' -------------------------------------------------------------------
' 4) Create the Picture object.
' Fill the GUID of the Picture object:
With udt_PicGUID
.Data1& = &H7BF80980
.Data2% = &HBF32
.Data3% = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Fill the PICTDESC structure:
With udt_Pic
.cbSizeofStruct& = Len(udt_Pic) ' Length of structure
.picType& = PICTYPE_BITMAP& ' Type of Picture (bitmap)
.hBitmap& = lng_hBmp& ' Handle to bitmap
.hPal& = lng_hPal& ' Handle to palette if one exists
End With
lng_Res& = OleCreatePictureIndirect(udt_Pic, udt_PicGUID, API_TRUE&,
obj_Pic)
If lng_Res& <> S_OK& Then
Set Load_BMP256 = Nothing
Set obj_Pic = Nothing
Err.Raise 51& ' Internal error (Error 51)
Else
Set Load_BMP256 = obj_Pic
Set obj_Pic = Nothing
End If
' -------------------------------------------------------------------
' Clean up:
Call SelectObject(lng_PicDC, lng_PrevBmp)
Call DeleteObject(lng_hBmp)
Call DeleteDC(lng_PicDC)
Call ReleaseDC(0, lng_ScrDC)
' -------------------------------------------------------------------
' This is the procedure exit subroutine:
Procedure_Exit:
Exit Function
' -------------------------------------------------------------------
' Error handling here:
Err_Handler:
With Err
.Source$ = "Load_BMP256"
.Raise .Number&
End With
' -------------------------------------------------------------------
End Function

' THE DECLARATIONS:

Option Explicit
Private Const BMP_FileSignature As Integer = &H4D42 ' BMP signature
Private Const DIB_RGB_COLORS As Long = 0
' API boolean values:
Private Const API_TRUE As Long = 1&
Private Const API_FALSE As Long = 0&
' Miscellaneous used in Win32API:
Private Const S_OK As Long = &H0 ' The new picture
object was created successfully.
Private Const E_NOINTERFACE As Long = &H80004002 ' The object does
not support the interface specified in riid.
Private Const E_POINTER As Long = &H80004003 ' The address in
pPictDesc or ppvObj is not valid. For example, it may be NULL.
Private Const E_INVALIDARG As Long = &H80070057
Private Const E_OUTOFMEMORY As Long = &H8007000E
Private Const E_UNEXPECTED As Long = &H8000FFFF
' PICTYPE Constants: Describe the type of picture in the picType member of
' the PICTDESC structure that is passed to OleCreatePictureIndirect.
Private Const PICTYPE_UNINITIALIZED As Long = -1&
Private Const PICTYPE_NONE As Long = 0&
Private Const PICTYPE_BITMAP As Long = 1&
Private Const PICTYPE_METAFILE As Long = 2&
Private Const PICTYPE_ICON As Long = 3&
Private Const PICTYPE_ENHMETAFILE As Long = 4&
Private Type PICTDESC
cbSizeofStruct As Long ' Size of the PICTDESC structure
picType As Long ' Type of picture in this structure.
hBitmap As Long ' The id of the bitmap for to the picture object
hPal As Long ' The id of the color palette for the bitmap
Reserved As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Type BITMAPFILEHEADER ' 14 bytes
bfType As Integer ' 2
bfSize As Long ' 4
bfReserved1 As Integer ' 2
bfReserved2 As Integer ' 2
bfOffBits As Long ' 4
End Type
' BMP info header record:
Private Type BITMAPINFOHEADER ' 40 bytes
biSize As Long ' 4
biWidth As Long ' 4
biHeight As Long ' 4
biPlanes As Integer ' 2
biBitCount As Integer ' 2
biCompression As Long ' 4
biSizeImage As Long ' 4
biXPelsPerMeter As Long ' 4
biYPelsPerMeter As Long ' 4
biClrUsed As Long ' 4
biClrImportant As Long ' 4
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors() As RGBQUAD
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function CreateBitmap Lib "gdi32.dll" ( _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, _
ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetBitmapBits Lib "gdi32.dll" ( _
ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" ( _
ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" ( _
ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32.dll" ( _
ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" ( _
ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As
Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" ( _
ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function SetDIBits Lib "gdi32.dll" (ByVal aHDC As Long, _
ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long,
_
lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function CreatePalette Lib "gdi32.dll" ( _
lpLogPalette As LOGPALETTE) As Long
Private Declare Function RealizePalette Lib "gdi32.dll" ( _
ByVal hdc As Long) As Long
Private Declare Function SelectPalette Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
Destination As Any, Source As Any, ByVal Length As Long)

[Schmidt]

I can't understand the problem with this function.
...
Public Function Load_BMP256( _
...

You over-complicated things.

I mean, come on - 285 lines of code for something the
LoadPicture-Function can solve in one line? ;-)

Ok, you perhaps need this for a game-engine or something,
since you want to restrict to 8bpp-Bitmaps with a 256-
Color-Palette only - but even then you can reduce your
code-volume about factor 10..., tried to keep all your
error-raising-stuff intact, including the FileNotExists -
error, which is implicitely raised by the FileLen-Function.

'***Into a Form
Option Explicit

Private Sub Form_Click()
Set Me.Picture = Load_BMP256("d:\8bpp.bmp")
End Sub

Public Function Load_BMP256(ByVal FileName As String) As IPictureDisp
Dim FNr&, FLen&, BMSig As String * 2, BMSize&, BMBits%

FileName = Trim$(FileName)
FLen = FileLen(FileName)

FNr = FreeFile
Open FileName For Binary Access Read As FNr
Get FNr, , BMSig
Get FNr, , BMSize
Get FNr, 29, BMBits
Close FNr

'Check for the file type signature 'BM':
If BMSig <> "BM" Then Err.Raise 321& 'Invalid FileFormat

'Confirm file size:
If BMSize <> FLen Then Err.Raise 321& 'Invalid FileFormat

'Check for valid bits per pixel:
Select Case BMBits
Case 1, 4, 16, 24, 32
Err.Raise vbObjectError + 1, , "The application does not support " _
& BMBits & "-bit bitmaps"
End Select

Set Load_BMP256 = LoadPicture(FileName)
End Function

Olaf

[Paulo]

Hi Olaf,

Thanks for responding. I am working in a prototype application and have a
few days to present it to a costumer in the textile industry. They have an
old software that generates, every working day, hundreds, sometimes more
than one thousand, of 256 color bitmaps (640x480) using com ports. This is
crazy. These bitmaps represent the changes of the status, operations,
pauses, and failures in the network of all the machines in the plant. At the
moment they need to analyse them and produce reports, but they don't know
how. My prototype is an atempt to automate the analysis by tracing the
bitmaps and output different color markers into the bitmaps and display
them. This task will be easier in paletted bitmaps. So, actually, I need to
split every bitmap in parts, perform tracing, analysis, TextOut, display and
store in sql database both text and graphics in 16 colors, perhaps. I am not
sure if this will work. Maybe I will have to change the whole approach, and
the design, as well.

I think the problem is with the SelectPalette, maybe. I have been trying to
find the error in the last couple of days. Can you help with this?

Thank you kindly for your input.

Paulo

Post by Schmidt

I can't understand the problem with this function.
...
Public Function Load_BMP256( _
...

You over-complicated things.
I mean, come on - 285 lines of code for something the
LoadPicture-Function can solve in one line? ;-)
Ok, you perhaps need this for a game-engine or something,
since you want to restrict to 8bpp-Bitmaps with a 256-
Color-Palette only - but even then you can reduce your
code-volume about factor 10..., tried to keep all your
error-raising-stuff intact, including the FileNotExists -
error, which is implicitely raised by the FileLen-Function.
'***Into a Form
Option Explicit
Private Sub Form_Click()
Set Me.Picture = Load_BMP256("d:\8bpp.bmp")
End Sub
Public Function Load_BMP256(ByVal FileName As String) As IPictureDisp
Dim FNr&, FLen&, BMSig As String * 2, BMSize&, BMBits%
FileName = Trim$(FileName)
FLen = FileLen(FileName)
FNr = FreeFile
Open FileName For Binary Access Read As FNr
Get FNr, , BMSig
Get FNr, , BMSize
Get FNr, 29, BMBits
Close FNr
If BMSig <> "BM" Then Err.Raise 321& 'Invalid FileFormat
If BMSize <> FLen Then Err.Raise 321& 'Invalid FileFormat
Select Case BMBits
Case 1, 4, 16, 24, 32
Err.Raise vbObjectError + 1, , "The application does not support " _
& BMBits & "-bit bitmaps"
End Select
Set Load_BMP256 = LoadPicture(FileName)
End Function
Olaf

[Schmidt]

Post by Paulo
My prototype is an atempt to automate the analysis by tracing the
bitmaps and output different color markers into the bitmaps and
display them. This task will be easier in paletted bitmaps.

Nope, not from my experience - it's easier to code and
perform a fast Image-Analysis on 32bpp-Bitmaps, represented
in a normal 2D-VB-Long-Array (each Pixel represented by
a 32Bit Long-Value). Especially when your Bitmaps are
smaller ones (only 640x480), then it's no large performance-
hog, when you "blow them up" to 32Bit.
After that, the Palette-Handling is not necessary anymore,
since each 2D-Array now contains direct Color-Values - and you
will also not have to deal with any "Scanline-Padding-issues"
anymore.

Post by Paulo
So, actually, I need to split every bitmap in parts, perform
tracing, analysis, TextOut, display and store in sql database
both text and graphics in 16 colors, perhaps.

As said, I would load your 256-Color Bitmaps as 32Bit ones
into 640x480 2D-Long-Arrays (or into a 2D-BGRQuad-Array, in
case you need direct access to the different Color-Channels
in your analysis- or tracing-routines and not just the "Color
of entire Pixels").

You can render directly from such a 2D-Array onto any hDC
(e.g. against a PictureBox-hDC) - then Overlay your TextOuts
against the same PictureBox (using normal VB-Print).

And for efficient storage, you could compress the 32Bit-
Array losless into *.png Format - or just use ZLib against
the 32Bit 2D-Array-Buffer and write this proprietary compressed
Format as Blob into the DB.

The compression should work well, despite the 32Bit per Pixel,
since such a blown up 256-Color image still contains only
256 Colors inside - so the compressor will shrink every
"blown up Bit away" again, without larger inefficiencies,
compared with the compression of e.g. the original 8Bit-Image.

If you don't bother shipping a (free) COM-lib with your Project,
then there'd be very good support for all the outlined tasks
already available (including png-compression of such 32Bit-
Buffers directly into VB-ByteArrays, fast Color-Manipulation-
functions, Gamma-Correction-stuff, blurring, sharpening...).

Anyways, here comes "plain VB-Code" - but I've omitted the
Png-Compression-stuff:

'***Into a Form, then Click the Form
Option Explicit

Private Declare Function GetDIBits& Lib "gdi32" (ByVal aHDC&, _
ByVal hBM&, ByVal nStartSL&, ByVal nNumSL&, lpBits As Any, _
lpBI As Any, ByVal wUsage&)
Private Declare Function GetDC& Lib "user32" (ByVal hWnd&)
Private Declare Function StretchDIBits& Lib "gdi32" (ByVal hDC&, _
ByVal x&, ByVal y&, ByVal dx&, ByVal dy&, ByVal SrcX&, ByVal SrcY&, _
ByVal Srcdx&, ByVal Srcdy&, lpBits As Any, lpBitsInfo As Any, ByVal _
wUsage&, ByVal dwRop&)
Private Declare Function ReleaseDC& Lib "user32" (ByVal hWnd&, ByVal DC&)

Private Type BGRQuad
B As Byte
G As Byte
R As Byte
A As Byte
End Type

Private Sub Form_Click()
ScaleMode = vbPixels 'to work with the Form-Container in Pixelspace

Dim Arr() As BGRQuad

'retrieve the 32Bit-Array directly from a StdPic
GetArrFromHdl Arr, Load_BMP256("D:\8bpp.bmp")

'demonstrate a simple Pixel-Looping-Manipulation
SetRedChannelToMaximum Arr

'Draw to any hDC directly from the Array
DrawArr Arr, Me.hDC

'Show TextOverlay "On-Screen"
Me.FontName = "Arial": Me.FontSize = 22
Me.CurrentX = 10: Me.CurrentY = 10
Me.Print "OnScreen-TextOverlay"

'Compress the Array in PNG-Format directly into Memory
'... left as an exercise <g>
End Sub

Private Sub SetRedChannelToMaximum(Arr() As BGRQuad)
Dim x As Long, y As Long
For y = 0 To UBound(Arr, 2)
For x = 0 To UBound(Arr, 1)
With Arr(x, y)
'.B = 0
'.G = 0
.R = 255
End With
Next x
Next y
End Sub

Private Sub GetArrFromHdl(P() As BGRQuad, ByVal Hdl&)
Dim BI&(9), TheDC&
TheDC = GetDC(0): ReDim P(0, 0): BI(0) = 40
GetDIBits TheDC, Hdl, 0, 0, ByVal 0&, BI(0), 0
If BI(1) = 0 Or BI(2) = 0 Then ReleaseDC 0, TheDC: Exit Sub
BI(3) = 1 + 65536 * 32: BI(4) = 0
ReDim P(BI(1) - 1, BI(2) - 1): BI(2) = -BI(2)
GetDIBits TheDC, Hdl, 0, -BI(2), P(0, 0), BI(0), 0
ReleaseDC 0, TheDC
End Sub

Private Sub DrawArr(P() As BGRQuad, DC&)
Dim BI&(9), W&, H&
On Error Resume Next
W = UBound(P, 1) + 1: H = UBound(P, 2) + 1
If W = 0 Or H = 0 Then Err.Clear: Exit Sub
BI(0) = 40: BI(1) = W: BI(2) = -H: BI(3) = 1 + 65536 * 32 '32bpp
StretchDIBits DC, 0, 0, W, H, 0, 0, W, H, P(0, 0), BI(0), 0, vbSrcCopy
End Sub

Function Load_BMP256(ByVal FileName As String) As IPictureDisp
Dim FNr&, FLen&, BMSig As String * 2, BMSize&, BMBits%

FileName = Trim$(FileName)
FLen = FileLen(FileName)

FNr = FreeFile
Open FileName For Binary Access Read As FNr
Get FNr, , BMSig
Get FNr, , BMSize
Get FNr, 29, BMBits
Close FNr

'Check for the file type signature 'BM':
If BMSig <> "BM" Then Err.Raise 321& 'Invalid FileFormat

'Confirm file size:
If BMSize <> FLen Then Err.Raise 321& 'Invalid FileFormat

'Check for valid bits per pixel:
Select Case BMBits
Case 1, 4, 16, 24, 32
Err.Raise vbObjectError + 1, , "The application does not support " _
& BMBits & "-bit bitmaps"
End Select

Set Load_BMP256 = LoadPicture(FileName)
End Function

Olaf

[Paulo]

Hi Olaf,

I'm going to try your suggestion because till the moment I couldn't put my
code to work. The solution will to change 24 or 32 bit color. A and till now
the color palette seems to be allways the same, which keeps things more
simple in what concerns analysis and compression.

Thank you for your advice and for your nice piece of code.

Paulo

Post by Schmidt

Post by Paulo
My prototype is an atempt to automate the analysis by tracing the
bitmaps and output different color markers into the bitmaps and
display them. This task will be easier in paletted bitmaps.

Nope, not from my experience - it's easier to code and
perform a fast Image-Analysis on 32bpp-Bitmaps, represented
in a normal 2D-VB-Long-Array (each Pixel represented by
a 32Bit Long-Value). Especially when your Bitmaps are
smaller ones (only 640x480), then it's no large performance-
hog, when you "blow them up" to 32Bit.
After that, the Palette-Handling is not necessary anymore,
since each 2D-Array now contains direct Color-Values - and you
will also not have to deal with any "Scanline-Padding-issues"
anymore.

Post by Paulo
So, actually, I need to split every bitmap in parts, perform
tracing, analysis, TextOut, display and store in sql database
both text and graphics in 16 colors, perhaps.

As said, I would load your 256-Color Bitmaps as 32Bit ones
into 640x480 2D-Long-Arrays (or into a 2D-BGRQuad-Array, in
case you need direct access to the different Color-Channels
in your analysis- or tracing-routines and not just the "Color
of entire Pixels").
You can render directly from such a 2D-Array onto any hDC
(e.g. against a PictureBox-hDC) - then Overlay your TextOuts
against the same PictureBox (using normal VB-Print).
And for efficient storage, you could compress the 32Bit-
Array losless into *.png Format - or just use ZLib against
the 32Bit 2D-Array-Buffer and write this proprietary compressed
Format as Blob into the DB.
The compression should work well, despite the 32Bit per Pixel,
since such a blown up 256-Color image still contains only
256 Colors inside - so the compressor will shrink every
"blown up Bit away" again, without larger inefficiencies,
compared with the compression of e.g. the original 8Bit-Image.
If you don't bother shipping a (free) COM-lib with your Project,
then there'd be very good support for all the outlined tasks
already available (including png-compression of such 32Bit-
Buffers directly into VB-ByteArrays, fast Color-Manipulation-
functions, Gamma-Correction-stuff, blurring, sharpening...).
Anyways, here comes "plain VB-Code" - but I've omitted the
'***Into a Form, then Click the Form
Option Explicit
Private Declare Function GetDIBits& Lib "gdi32" (ByVal aHDC&, _
ByVal hBM&, ByVal nStartSL&, ByVal nNumSL&, lpBits As Any, _
lpBI As Any, ByVal wUsage&)
Private Declare Function GetDC& Lib "user32" (ByVal hWnd&)
Private Declare Function StretchDIBits& Lib "gdi32" (ByVal hDC&, _
ByVal x&, ByVal y&, ByVal dx&, ByVal dy&, ByVal SrcX&, ByVal SrcY&, _
ByVal Srcdx&, ByVal Srcdy&, lpBits As Any, lpBitsInfo As Any, ByVal _
wUsage&, ByVal dwRop&)
Private Declare Function ReleaseDC& Lib "user32" (ByVal hWnd&, ByVal DC&)
Private Type BGRQuad
B As Byte
G As Byte
R As Byte
A As Byte
End Type
Private Sub Form_Click()
ScaleMode = vbPixels 'to work with the Form-Container in Pixelspace
Dim Arr() As BGRQuad
'retrieve the 32Bit-Array directly from a StdPic
GetArrFromHdl Arr, Load_BMP256("D:\8bpp.bmp")
'demonstrate a simple Pixel-Looping-Manipulation
SetRedChannelToMaximum Arr
'Draw to any hDC directly from the Array
DrawArr Arr, Me.hDC
'Show TextOverlay "On-Screen"
Me.FontName = "Arial": Me.FontSize = 22
Me.CurrentX = 10: Me.CurrentY = 10
Me.Print "OnScreen-TextOverlay"
'Compress the Array in PNG-Format directly into Memory
'... left as an exercise <g>
End Sub
Private Sub SetRedChannelToMaximum(Arr() As BGRQuad)
Dim x As Long, y As Long
For y = 0 To UBound(Arr, 2)
For x = 0 To UBound(Arr, 1)
With Arr(x, y)
'.B = 0
'.G = 0
.R = 255
End With
Next x
Next y
End Sub
Private Sub GetArrFromHdl(P() As BGRQuad, ByVal Hdl&)
Dim BI&(9), TheDC&
TheDC = GetDC(0): ReDim P(0, 0): BI(0) = 40
GetDIBits TheDC, Hdl, 0, 0, ByVal 0&, BI(0), 0
If BI(1) = 0 Or BI(2) = 0 Then ReleaseDC 0, TheDC: Exit Sub
BI(3) = 1 + 65536 * 32: BI(4) = 0
ReDim P(BI(1) - 1, BI(2) - 1): BI(2) = -BI(2)
GetDIBits TheDC, Hdl, 0, -BI(2), P(0, 0), BI(0), 0
ReleaseDC 0, TheDC
End Sub
Private Sub DrawArr(P() As BGRQuad, DC&)
Dim BI&(9), W&, H&
On Error Resume Next
W = UBound(P, 1) + 1: H = UBound(P, 2) + 1
If W = 0 Or H = 0 Then Err.Clear: Exit Sub
BI(0) = 40: BI(1) = W: BI(2) = -H: BI(3) = 1 + 65536 * 32 '32bpp
StretchDIBits DC, 0, 0, W, H, 0, 0, W, H, P(0, 0), BI(0), 0, vbSrcCopy
End Sub
Function Load_BMP256(ByVal FileName As String) As IPictureDisp
Dim FNr&, FLen&, BMSig As String * 2, BMSize&, BMBits%
FileName = Trim$(FileName)
FLen = FileLen(FileName)
FNr = FreeFile
Open FileName For Binary Access Read As FNr
Get FNr, , BMSig
Get FNr, , BMSize
Get FNr, 29, BMBits
Close FNr
If BMSig <> "BM" Then Err.Raise 321& 'Invalid FileFormat
If BMSize <> FLen Then Err.Raise 321& 'Invalid FileFormat
Select Case BMBits
Case 1, 4, 16, 24, 32
Err.Raise vbObjectError + 1, , "The application does not support " _
& BMBits & "-bit bitmaps"
End Select
Set Load_BMP256 = LoadPicture(FileName)
End Function
Olaf