Make a * .bmp image from binary data
How can I create a * .bmp image using 1 bit per pixel using VB6? Is there a sample project for something like this?
'# # Image Data Info : #
'# # Each black dot are represented as binary 1(high)#
'# # and white are represented as binary 0(low) in #
'# # form of hexadecimal character. #
'# # Example : (for this example assume the image width is 8)#
'# # Data : 7E817E #
'# # Binary data : 7=0111, E=1110, 8=1000, 1=0001 #
'# # 7=0111, E=1110 #
'# # Image data : px1 px2 px3 px4 px5 px6 px7 px8 #
'# # px1 w b b b b b b w #
'# # px2 b w w w w w w b #
'# # px3 w b b b b b b w #
'# # #
'# # w = white, b = black, px = pixel #
More details:
+3
source to share
1 answer
You can use the following code, please note that:
- image width must be a multiple of 8;
- lines start from the bottom;
If these requirements are not suitable for you, the code can be corrected accordingly.
Option Explicit
Private Type BITMAPFILEHEADER
bfType As String * 2
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 Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type
Public Function strToBmp(str As String, w As Integer, h As Integer, filename As String) As Boolean
Dim bmfh As BITMAPFILEHEADER
Dim bmi As BITMAPINFO
Dim r As Boolean
Dim ff As Integer
Dim i As Integer
Dim x As Integer
Dim rl As Integer
Dim rw As Integer
Dim s As String
Dim b As Byte
rw = ((w + 31) \ 32 + 3) And &HFFFFFFFC
With bmfh
.bfType = "BM"
.bfSize = Len(bmfh) + Len(bmi) + rw * h
.bfOffBits = Len(bmfh) + Len(bmi)
End With
With bmi.bmiHeader
.biSize = Len(bmi.bmiHeader)
.biWidth = w
.biHeight = h
.biPlanes = 1
.biBitCount = 1
.biCompression = 0
.biSizeImage = rw * h
.biXPelsPerMeter = 72
.biYPelsPerMeter = 72
.biClrUsed = 0
.biClrImportant = 0
End With
With bmi.bmiColors(0)
.rgbRed = 255
.rgbGreen = 255
.rgbBlue = 255
End With
On Error Resume Next
Call Kill(filename)
On Error GoTo e2
ff = FreeFile()
Open filename For Binary Access Write As #ff
On Error GoTo e1
Put #ff, , bmfh
Put #ff, , bmi
For i = 1 To Len(str) Step 2
b = CByte("&H" & Mid(str, i, 2))
Put #ff, , b
rl = rl + 1
x = x + 8
If x = w Then
b = 0
Do While rl < rw
Put #ff, , b
rl = rl + 1
Loop
x = 0
rl = 0
End If
Next i
r = True
e1:
Close ff
e2:
strToBmp = r
End Function
Public Sub test()
Call strToBmp("7E817E", 8, 3, "out.bmp")
End Sub
This is the resulting image:
Also note that Microsoft Paint seems to have a bug that affects monochromatic images, resulting in some pixels scrambling.
0
source to share