DevX Home    Today's Headlines   Articles Archive   Tip Bank   Forums   

Results 1 to 9 of 9

Thread: bmp B&W from color bmp

Hybrid View

  1. #1
    Join Date
    Aug 2004
    Posts
    43,023

    bmp B&W from color bmp

    [Originally posted by Javier Balkenende]

    Hi, I need to convert a color bitmap to a black & white bitmap. How can i do that?
    Thanks,

    Javier

  2. #2
    Join Date
    Aug 2004
    Posts
    43,023

    Re:bmp B&W from color bmp

    [Originally posted by neophile]

    Black and white... not grayscale?

  3. #3
    Join Date
    Aug 2004
    Posts
    43,023

    Re:bmp B&W from color bmp

    [Originally posted by neophile]

    I'll just assume greyscale here since all the methods work on single pixels (whereas different black & white methods requires error diffusion)

    Anyway, this code isn't all that fast but it demonstrates the different reduction methods visually. This can be done alot faster using DIBs, but here you go...


    ' On a Form
    ' Place two PictureBox's and load a picture into the first
    ' Place a CommandButton and a ListBox
    Option Explicit

    Public Enum GreyMethods
    gITU = 0
    gNTSCPAL = 1
    gAverage = 2
    gWeighted = 3
    gVector = 4
    gEye = 5
    End Enum

    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long


    Private Sub Form_Load()
    List1.AddItem "ITU Standard"
    List1.AddItem "NTSC & PAL"
    List1.AddItem "Simple Average"
    List1.AddItem "Weighted Average"
    List1.AddItem "Color Cube"
    List1.AddItem "Human Eye"
    List1.ListIndex = 0
    End Sub

    Private Sub Command1_Click()
    Dim iX As Integer
    Dim iY As Integer
    Dim iM As Integer

    Command1.Enabled = False
    Me.MousePointer = vbArrowHourglass
    Picture1.ScaleMode = vbPixels
    Picture2.Width = Picture1.Width
    Picture2.Height = Picture1.Height
    Picture2.AutoRedraw = True
    iM = List1.ListIndex
    For iY = 0 To Picture1.ScaleHeight - 1
    For iX = 0 To Picture1.ScaleWidth - 1
    SetPixel Picture2.hdc, iX, iY, ToGrey(GetPixel(Picture1.hdc, iX, iY), iM)
    Next
    Picture2.Refresh
    DoEvents
    Next
    Command1.Enabled = True
    Me.MousePointer = vbDefault
    End Sub

    Private Function ToGrey(ByVal Color As Long, Optional ByVal Method As GreyMethods = gITU) As Long
    Dim iR As Integer
    Dim iG As Integer
    Dim iB As Integer
    Dim iC As Integer

    iR = Color And 255
    iG = (Color \ 256) And 255
    iB = (Color \ 65536) And 255
    Select Case Method
    Case gITU ' International Telecommunications Union standard - recommended
    iC = (0.2125 * iR + 0.7154 * iG + 0.0721 * iB)
    Case gNTSCPAL ' NTSC and PAL
    iC = (0.299 * iR + 0.587 * iG + 0.114 * iB)
    Case gAverage ' Simple average
    iC = (iR + iG + iB) / 3
    Case gWeighted ' Weighted average - common
    iC = (3 * iR + 4 * iG + 2 * iB) / 9
    Case gVector ' Distance of color vector in color cube - not recommended
    iC = Sqr(iR ^ 2 + iG ^ 2 + iB ^ 2)
    Case gEye ' Human eye responsive - not recommended (ignores red & blue)
    iC = iG
    End Select
    ToGrey = RGB(iC, iC, iC)
    End Function

  4. #4
    Join Date
    Aug 2004
    Posts
    43,023

    Re:Re:bmp B&W from color bmp

    [Originally posted by Javier Balkenende]

    Sorry, I mean grayscale.
    I will tray the code, but I need fast proccesing.
    Thanks,

    Javier

  5. #5
    Join Date
    Aug 2004
    Posts
    43,023

    Re:Re:Re:bmp B&W from color bmp

    [Originally posted by neophile]

    It can be sped up using GetDIBits and SetDIBitsToDevice. Do you need to save these images as 256-color bitmaps? Or is this just for displaying?

  6. #6
    Join Date
    Aug 2004
    Posts
    43,023

    Re:Re:Re:bmp B&W from color bmp

    [Originally posted by neophile]

    Here's some code to help end the woes ;) Here are two functions that use the ITU algorithm.
    Bit24ToGrey24 is primarily for display purposes...

    Picture2.Picture = Bit24ToGrey24(Picture1.Picture)

    And Bit24ToGrey8File is for saving as a 256-color bitmap...

    Bit24ToGrey8File Picture1.Picture, "C:\grey256.bmp"


    Anyway, here's the code...


    'In a module...
    Option Explicit

    Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
    End Type

    Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
    End Type

    Private Type BITMAPINFO
    Size As Long
    Width As Long
    Height As Long
    Planes As Integer
    BitCount As Integer
    Compression As Long
    SizeImage As Long
    XPelsPerMeter As Long
    YPelsPerMeter As Long
    ClrUsed As Long
    ClrImportant As Long
    End Type

    Private Type RGBQUAD
    Blue As Byte
    Green As Byte
    Red As Byte
    Reserved As Byte
    End Type

    Private Type BITMAP
    Type As Long
    Width As Long
    Height As Long
    WidthBytes As Long
    Planes As Integer
    BitsPixel As Integer
    Bits As Long
    End Type

    Private Type BITMAPFILEHEADER
    Type As String * 2
    Size As Long
    Reserved1 As Integer
    Reserved2 As Integer
    OffBits As Long
    End Type

    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 OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal imageType As Long, ByVal NewWidth As Long, ByVal NewHeight As Long, ByVal lFlags As Long) As Long
    Private Declare Function GetDIBits Lib "gdi32" (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 SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) 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


    Public Function Bit24toGrey24(ByVal Image As Long) As Picture
    Dim vBMP As BITMAP
    Dim lBmp As Long
    Dim lDC As Long
    Dim vBMI As BITMAPINFO
    Dim bBits() As Byte
    Dim iPad As Integer
    Dim lX As Long
    Dim lY As Long
    Dim lP As Long
    Dim iId As Long
    Dim bFile As Boolean

    Call GetObject(Image, Len(vBMP), vBMP)
    If vBMP.BitsPixel = 24 Then
    lBmp = CopyImage(Image, 0, 0, 0, 0)
    lDC = CreateCompatibleDC(0)
    With vBMI
    .BitCount = 24
    .Width = vBMP.Width
    .Height = vBMP.Height
    .Planes = vBMP.Planes
    .Size = Len(vBMI)
    End With
    iPad = CalcPadding(vBMP.Width, 24)
    ReDim bBits((((vBMP.Width * 3) + iPad) * vBMP.Height) - 1)
    Call SelectObject(lDC, lBmp)
    Call GetDIBits(lDC, lBmp, 0, vBMP.Height, bBits(0), vBMI, 0)
    For lY = 0 To vBMP.Height - 1
    For lX = 0 To vBMP.Width - 1
    lP = (lY * ((vBMP.Width * 3) + iPad)) + (lX * 3)
    iId = (0.2125 * bBits(lP + 2) + 0.7154 * bBits(lP + 1) + 0.0721 * bBits(lP))
    bBits(lP + 2) = iId
    bBits(lP + 1) = iId
    bBits(lP) = iId
    Next
    Next
    Call SetDIBitsToDevice(lDC, 0, 0, vBMP.Width, vBMP.Height, 0, 0, 0, vBMP.Height, bBits(0), vBMI, 0)
    Set Bit24toGrey24 = ConvertToPicture(lBmp)
    DeleteDC lDC
    End If
    End Function

    Public Function Bit24ToGrey8File(ByVal Image As Long, ByVal Filename As String) As Boolean
    Dim vBMP As BITMAP
    Dim lBmp As Long
    Dim lDC As Long
    Dim vBMI As BITMAPINFO
    Dim bBits() As Byte
    Dim bBits8() As Byte
    Dim iPad As Integer
    Dim iPad8 As Integer
    Dim lX As Long
    Dim lY As Long
    Dim lP As Long
    Dim iId As Long
    Dim vPal() As RGBQUAD
    Dim vBMF As BITMAPFILEHEADER
    Dim fn As Integer

    Call GetObject(Image, Len(vBMP), vBMP)
    If vBMP.BitsPixel = 24 Then
    lBmp = CopyImage(Image, 0, 0, 0, 0)
    lDC = CreateCompatibleDC(0)
    With vBMI
    .BitCount = 24
    .Width = vBMP.Width
    .Height = vBMP.Height
    .Planes = vBMP.Planes
    .Size = Len(vBMI)
    End With
    iPad = CalcPadding(vBMP.Width, 24)
    iPad8 = CalcPadding(vBMP.Width, 8)
    ReDim bBits((((vBMP.Width * 3) + iPad) * vBMP.Height) - 1)
    ReDim bBits8(((vBMP.Width + iPad8) * vBMP.Height) - 1)
    Call SelectObject(lDC, lBmp)
    Call GetDIBits(lDC, lBmp, 0, vBMP.Height, bBits(0), vBMI, 0)
    For lY = 0 To vBMP.Height - 1
    For lX = 0 To vBMP.Width - 1
    lP = (lY * ((vBMP.Width * 3) + iPad)) + (lX * 3)
    iId = (0.2125 * bBits(lP + 2) + 0.7154 * bBits(lP + 1) + 0.0721 * bBits(lP))
    bBits8(lY * (vBMP.Width + iPad) + lX) = iId
    Next
    Next
    DeleteDC lDC
    DeleteObject lBmp
    Erase bBits
    ReDim vPal(255)
    For lX = 0 To 255
    With vPal(lX)
    .Red = lX
    .Green = lX
    .Blue = lX
    End With
    Next
    With vBMI
    .BitCount = 8
    .ClrUsed = 256
    .ClrImportant = 256
    .SizeImage = UBound(bBits8) + 1
    End With
    With vBMF
    .Type = "BM"
    .OffBits = Len(vBMI) + Len(vBMF) + ((UBound(vPal) + 1) * 4)
    .Size = .OffBits + vBMI.SizeImage
    End With
    fn = FreeFile
    Open Filename For Binary Lock Write As fn
    Put fn, , vBMF
    Put fn, , vBMI
    Put fn, , vPal
    Put fn, , bBits8
    Close fn
    Erase vPal
    Erase bBits8
    Bit24ToGrey8File = True
    End If
    End Function

    Private Function CalcPadding(ByVal Width As Long, ByVal BitsPixel As Integer) As Integer
    CalcPadding = (32 - ((Width * BitsPixel) Mod 32))
    If CalcPadding = 32 Then CalcPadding = 0
    CalcPadding = CalcPadding \ BitsPixel
    End Function

    Private Function ConvertToPicture(ByVal Image As Long) As Picture
    Dim vIDispatch As GUID
    Dim vPic As PicBmp

    With vIDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
    End With
    With vPic
    .Size = Len(vPic)
    .Type = vbPicTypeBitmap
    .hBmp = Image
    End With
    Call OleCreatePictureIndirect(vPic, vIDispatch, 1, ConvertToPicture)
    End Function



    Both functions are about as fast as you can get in VB. Have fun! ;)

  7. #7
    Join Date
    Aug 2004
    Posts
    43,023

    Re:Re:Re:Re:bmp B&W from color bmp

    [Originally posted by Javier Balkenende]

    Hi neophile:

    Sorry I didn't write before, but i was without a connection to Internet. I already have implemented the code you have post at first, and it is working great. It seems to be fast enough for that task.
    Thank you very much.
    I also will test the new code you wrote.

    Javier

  8. #8
    Join Date
    Aug 2004
    Posts
    43,023

    Re:Re:Re:Re:Re:bmp B&W from color bmp

    [Originally posted by neophile]

    The new stuff I posted is hundreds of times faster. Also, if you do a native compile with all optimizations turned on, it could be roughly 50 to 100 times faster ;)

  9. #9
    Join Date
    Aug 2004
    Posts
    43,023

    Re:Re:Re:Re:Re:Re:bmp B&W from color bmp

    [Originally posted by Javier Balkenende]

    Thanks neophile

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
HTML5 Development Center
 
 
FAQ
Latest Articles
Java
.NET
XML
Database
Enterprise
Questions? Contact us.
C++
Web Development
Wireless
Latest Tips
Open Source


   Development Centers

   -- Android Development Center
   -- Cloud Development Project Center
   -- HTML5 Development Center
   -- Windows Mobile Development Center