Private Sub Convert24BitTo1Bit(ByVal iFileName As String)
Dim Bitmap24 As BITMAPFILE24Bit
Dim Bitmap As BITMAPFILE
Dim sFormat As String
Dim ScanLineLen As Long
Dim ScanLine24Len As Long
Dim Pos As Integer
Dim R As Integer
Dim G As Integer
Dim B As Integer
Dim x As Integer
Dim y As Integer
Dim CurBit As Byte
Dim TmpByte As Byte
LoadBitmap iFileName, Bitmap, Bitmap24, sFormat
If sFormat <> "24Bit" Then Exit Sub
Bitmap.bmih.biSize = Len(Bitmap.bmih)
Bitmap.bmih.biWidth = Bitmap24.bmih.biWidth
Bitmap.bmih.biHeight = Bitmap24.bmih.biHeight
Bitmap.bmih.biPlanes = Bitmap24.bmih.biPlanes
Bitmap.bmih.biBitCount = 1
Bitmap.bmih.biCompression = 0& ' RGB
ScanLineLen = (RoundUp((Bitmap.bmih.biWidth / 8) / 4) * 4)
ScanLine24Len = (RoundUp((Bitmap.bmih.biWidth * 3) / 4) * 4)
Bitmap.bmih.biSizeImage = ScanLineLen * Bitmap.bmih.biHeight
Bitmap.bmih.biXPelsPerMeter = Bitmap24.bmih.biXPelsPerMeter
Bitmap.bmih.biYPelsPerMeter = Bitmap24.bmih.biYPelsPerMeter
Bitmap.bmih.biClrUsed = 2
Bitmap.bmih.biClrImportant = 2
Bitmap.bmfh.bfOffBits = Len(Bitmap.bmfh) + Len(Bitmap.bmih) + (Len(Bitmap.aColors(0)) * Bitmap.bmih.biClrUsed)
Bitmap.bmfh.bfType = &H4D42
Bitmap.bmfh.bfSize = Bitmap.bmfh.bfOffBits + Bitmap.bmih.biSizeImage
Bitmap.bmfh.bfReserved1 = 0
Bitmap.bmfh.bfReserved2 = 0
ReDim Bitmap.aColors(0 To Bitmap.bmih.biClrUsed - 1)
Bitmap.aColors(0).B = 0: Bitmap.aColors(0).G = 0: Bitmap.aColors(0).R = 0: Bitmap.aColors(0).Reserved = 0
Bitmap.aColors(1).B = 255: Bitmap.aColors(1).G = 255: Bitmap.aColors(1).R = 255: Bitmap.aColors(1).Reserved = 0
ReDim Bitmap.aBitmapBits(0 To Bitmap.bmih.biSizeImage - 1)
For y = 0 To Bitmap.bmih.biHeight - 1
Pos = y * ScanLineLen
CurBit = 128
For x = 0 To Bitmap.bmih.biWidth - 1
'For every pixel in the file (x,y)...
B = Bitmap24.aBitmapBits((y * ScanLine24Len) + (x * 3))
G = Bitmap24.aBitmapBits((y * ScanLine24Len) + (x * 3) + 1)
R = Bitmap24.aBitmapBits((y * ScanLine24Len) + (x * 3) + 2)
If R = 0 And G = 0 And B = 0 Then
'This pixel is black...
'We dont really need to do this bit because by default the bits will
'already be set to zero. I thought I'd show you how to anyway...
TmpByte = 255 Xor CurBit
Bitmap.aBitmapBits(Pos) = Bitmap.aBitmapBits(Pos) And TmpByte
Else
'This pixel is none black so we assume its white...
Bitmap.aBitmapBits(Pos) = Bitmap.aBitmapBits(Pos) Or CurBit
End If
If CurBit = 1 Then
CurBit = 128
Pos = Pos + 1
Else
CurBit = CurBit / 2
End If
Next
Next
'Delete the file becuase the one we create is smaller...
'--------------------------------------
Kill iFileName
'--------------------------------------
Open iFileName For Binary As #1
Put #1, , Bitmap.bmfh
Put #1, , Bitmap.bmih
Put #1, , Bitmap.aColors
Put #1, , Bitmap.aBitmapBits
Close #1
End Sub
