Results 1 to 16 of 16

Thread: Convert color images to black and white

  1. #1

    Thread Starter
    New Member
    Join Date
    Dec 2008
    Posts
    12

    Convert color images to black and white

    Hi,

    I need a code to convert a set of color images to black and white using VB 6. I need this immediately. Can anyone send me the details about this.

    Thanks in Advance

  2. #2
    Hyperactive Member
    Join Date
    Jun 2005
    Posts
    399

    Re: Convert color images to black and white

    I'd do something like this


    get dimensions of the image... have 2 for loops.. for X and Y..
    get each individual pixel .. convert to greyscale depending on the pixel.. repaint pixel in new image

    if you cant use any shades of grey.. and just black or white.. then id convert to greyscale then if its value is over a certain # id convert to black, if not convert to white.


    Hopefully this is clear..

  3. #3

    Thread Starter
    New Member
    Join Date
    Dec 2008
    Posts
    12

    Re: Convert color images to black and white

    I tried the same. Below is the code. After running the application the color is not changed to black and white.TempColor and NewColor values are always zero in loop.



    Code:
    Dim XPos As Long
        Dim YPos As Long
        Dim TempColour As Long
        Dim NewColour As Long
        Dim FileName As String
        FileName = "D:\\Copy of bday3.jpg"
        Dim NewFileName As String
        NewFileName = "D:\\N3.jpg"
        Picture1.Picture = LoadPicture(FileName)
        Picture1.ScaleMode = vbPixels
        X = Picture1.ScaleWidth
        y = Picture1.ScaleHeight
        
        For i = 0 To y - 1
            For j = 0 To X - 1
                TempColour = (Picture1.Point(j, i) / (vbWhite / 255))
                NewColour = TempColour * (vbWhite / 255)
                Picture1.PSet (XPos, YPos), NewColour
              
            Next
        Next
        Picture1.ScaleMode = vbTwips

  4. #4
    Hyperactive Member
    Join Date
    Jun 2005
    Posts
    399

    Re: Convert color images to black and white

    change
    Picture1.PSet (XPos, YPos), NewColour


    to
    Picture1.PSet (j ,i), NewColour

    and it should work

  5. #5
    Frenzied Member some1uk03's Avatar
    Join Date
    Jun 2006
    Location
    London, UK
    Posts
    1,663

    Re: Convert color images to black and white

    You're better off using the GetPixel / SetPixel APIs.. much faster to read/write each pixel.
    _____________________________________________________________________

    ----If this post has helped you. Please take time to Rate it.
    ----If you've solved your problem, then please mark it as RESOLVED from Thread Tools.



  6. #6

    Thread Starter
    New Member
    Join Date
    Dec 2008
    Posts
    12

    Re: Convert color images to black and white

    I tried changing to Picture1.PSet (j, i), NewColour.
    Still it is not working. NewColour has the value zero always.

  7. #7

    Thread Starter
    New Member
    Join Date
    Dec 2008
    Posts
    12

    Re: Convert color images to black and white

    I am not familiar with GetPixel and SetPixel. how to use these APIs

  8. #8
    Hyperactive Member
    Join Date
    Jun 2005
    Posts
    399

    Re: Convert color images to black and white

    I am using this exact code and it works for me

    Code:
    Private Sub Command1_Click()
    
        Dim TempColour As Long
        Dim NewColour As Long
        Dim FileName As String
        FileName = "C:\\test.jpg"
        Dim NewFileName As String
        NewFileName = "C:\\new.jpg"
        Picture1.Picture = LoadPicture(FileName)
        Picture1.ScaleMode = vbPixels
        x = Picture1.ScaleWidth
        y = Picture1.ScaleHeight
        
        For i = 0 To y - 1
            For j = 0 To x - 1
               TempColour = (Picture1.Point(j, i) / (vbWhite / 255))
                NewColour = TempColour * (vbWhite / 255)
    
                Picture1.PSet (j, i), NewColour
               
            Next
        Next
    
        
    
        Picture1.ScaleMode = vbTwips
    End Sub

  9. #9
    Fanatic Member technorobbo's Avatar
    Join Date
    Dec 2008
    Location
    Chicago
    Posts
    864

    Re: Convert color images to black and white

    Using the API - it's really fast.
    This was post edited because I posted a method I use on VBA ThundeFrames (CommandButton should have been a dead giveaway)
    Below is a VB method

    Code:
    Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) 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 Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    
    Private Sub Command1_Click()
    
    Dim x As Long, y As Long
    Dim holdBmp As Long, hMemDC As Long, PicInfo As BITMAP
    Dim sample As Long
    
    GetObject Picture1.Image, Len(PicInfo), PicInfo
    
    For x = 0 To PicInfo.bmWidth - 1
        For y = 0 To PicInfo.bmHeight - 1
            sample = GetPixel(Picture1.hdc, x, y)
            sample = (sample And &HFF) * &H10101
            SetPixel Picture1.hdc, x, y, sample
        Next
    Next
    Picture1.Refresh
    
    
    End Sub
    Last edited by technorobbo; Dec 12th, 2008 at 09:32 PM. Reason: Because I posted a method I use on VBA ThundeFrames
    Have Fun,

    TR
    _____________________________
    Check out my Alpha DogFighter2D Game Demo and Source code. Direct Download:http://home.comcast.net/~technorobbo/Alpha.zip or Read about it in the forum:http://www.vbforums.com/showthread.php?t=551700. Now in 3D!!! http://home.comcast.net/~technorobbo/AlPha3D.zip or read about it in the forum: http://www.vbforums.com/showthread.php?goto=newpost&t=552560 and IChessChat3D internet chess game

  10. #10
    VB For Fun Edgemeal's Avatar
    Join Date
    Sep 2006
    Location
    WindowFromPoint
    Posts
    4,255

    Re: Convert color images to black and white

    Here's a couple routines that seem to be pretty fast,

    Convert Picture box image to GrayScale or MonoChrome(B&W)

    Code:
    Option Explicit
    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 BITMAPINFO1
        bmiHeader As BITMAPINFOHEADER
        bmiColors(1) As RGBQUAD
    End Type
    
    Private Type BITMAPINFO8
        bmiHeader As BITMAPINFOHEADER
        bmiColors(255) As RGBQUAD
    End Type
    
     Private Declare Function CreateDIBSection1 Lib "gdi32" _
        Alias "CreateDIBSection" (ByVal hdc As Long, _
        pBitmapInfo As BITMAPINFO1, ByVal un As Long, _
        ByVal lplpVoid As Long, ByVal handle As Long, _
        ByVal dw As Long) As Long
    
    Private Declare Function CreateDIBSection8 Lib "gdi32" _
        Alias "CreateDIBSection" (ByVal hdc As Long, _
        pBitmapInfo As BITMAPINFO8, ByVal un As Long, _
        ByVal lplpVoid As Long, ByVal handle As Long, _
        ByVal dw As Long) 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc 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 Sub GrayScale_Click()
        ' // Convert Picture1 to GrayScale //
        Dim DeskWnd As Long, DeskDC As Long
        Dim MyDC As Long
        Dim MyDIB As Long, OldDIB As Long
        Dim DIBInf As BITMAPINFO8
        Dim MakePal As Long
        
        Picture1.AutoRedraw = True
        
        ' Create DC based on desktop DC
        DeskWnd = GetDesktopWindow()
        DeskDC = GetDC(DeskWnd)
        MyDC = CreateCompatibleDC(DeskDC)
        ReleaseDC DeskWnd, DeskDC
        ' Validate DC
        If (MyDC = 0) Then Exit Sub
        ' Set DIB information
        With DIBInf
            With .bmiHeader ' Same size as picture
                .biWidth = Picture1.ScaleX(Picture1.ScaleWidth, Picture1.ScaleMode, vbPixels)
                .biHeight = Picture1.ScaleY(Picture1.ScaleHeight, Picture1.ScaleMode, vbPixels)
                .biBitCount = 8
                .biPlanes = 1
                .biClrUsed = 256
                .biClrImportant = 256
                .biSize = Len(DIBInf.bmiHeader)
            End With
            ' Palette is Greyscale
            For MakePal = 0 To 255
                With .bmiColors(MakePal)
                    .rgbRed = MakePal
                    .rgbGreen = MakePal
                    .rgbBlue = MakePal
                End With
            Next MakePal
        End With
        ' Create the DIBSection
        MyDIB = CreateDIBSection8(MyDC, DIBInf, 0, ByVal 0&, 0, 0)
        If (MyDIB) Then ' Validate and select DIB
            OldDIB = SelectObject(MyDC, MyDIB)
            ' Draw original picture to the greyscale DIB
            BitBlt MyDC, 0, 0, DIBInf.bmiHeader.biWidth, DIBInf.bmiHeader.biHeight, Picture1.hdc, 0, 0, vbSrcCopy
            ' Draw the greyscale image back to picture box 1
            BitBlt Picture1.hdc, 0, 0, DIBInf.bmiHeader.biWidth, DIBInf.bmiHeader.biHeight, MyDC, 0, 0, vbSrcCopy
            ' Clean up DIB
            SelectObject MyDC, OldDIB
            DeleteObject MyDIB
        End If
        ' Clean up DC
        DeleteDC MyDC
        ' Redraw
        Picture1.Refresh
    End Sub
    
    Private Sub MonoChrome_Click()
        ' // Convert Picture1 to B&W //
        Dim DeskWnd As Long, DeskDC As Long
        Dim MyDC As Long
        Dim MyDIB As Long, OldDIB As Long
        Dim DIBInf As BITMAPINFO1
        
        Picture1.AutoRedraw = True
    
        'Create DC based on desktop DC
        DeskWnd = GetDesktopWindow()
        DeskDC = GetDC(DeskWnd)
        MyDC = CreateCompatibleDC(DeskDC)
        ReleaseDC DeskWnd, DeskDC
        'Validate DC
        If (MyDC = 0) Then Exit Sub
        'Set DIB information
        With DIBInf
            With .bmiHeader 'Same size as picture
                .biWidth = Picture1.ScaleX(Picture1.ScaleWidth, Picture1.ScaleMode, vbPixels)
                .biHeight = Picture1.ScaleY(Picture1.ScaleHeight, Picture1.ScaleMode, vbPixels)
                .biBitCount = 1
                .biPlanes = 1
                .biClrUsed = 2
                .biClrImportant = 2
                .biSize = Len(DIBInf.bmiHeader)
            End With
            ' Palette is Black ...
            With .bmiColors(0)
                .rgbRed = &H0
                .rgbGreen = &H0
                .rgbBlue = &H0
            End With
            ' ... and white
            With .bmiColors(1)
                .rgbRed = &HFF
                .rgbGreen = &HFF
                .rgbBlue = &HFF
            End With
        End With
        ' Create the DIBSection
        MyDIB = CreateDIBSection1(MyDC, DIBInf, 0, ByVal 0&, 0, 0)
        If (MyDIB) Then ' Validate and select DIB
            OldDIB = SelectObject(MyDC, MyDIB)
               BitBlt MyDC, 0, 0, DIBInf.bmiHeader.biWidth, DIBInf.bmiHeader.biHeight, Picture1.hdc, 0, 0, vbSrcCopy
            ' Draw the monochome image back to the picture box
            BitBlt Picture1.hdc, 0, 0, DIBInf.bmiHeader.biWidth, DIBInf.bmiHeader.biHeight, MyDC, 0, 0, vbSrcCopy
            ' Clean up DIB
            SelectObject MyDC, OldDIB
            DeleteObject MyDIB
        End If
        ' Clean up DC
        DeleteDC MyDC
        ' Redraw
        Picture1.Refresh
    End Sub

  11. #11

    Thread Starter
    New Member
    Join Date
    Dec 2008
    Posts
    12

    Re: Convert color images to black and white

    Thanks to all

    I copied the code from Form_Load to Command1_Click event it worked.

    But my actual requirement is to convert a set of color images to black and white. I need to read each image from a folder, convert it to black and white and save it with the same name. I am able to do it in .net. I need help to do the same in VB6.

    Without using PictureBox or any control is it possible?

  12. #12

    Thread Starter
    New Member
    Join Date
    Dec 2008
    Posts
    12

    Re: Convert color images to black and white

    Can anyone help in exporting or saving the image from picturebox to a folder with type jpeg ?

  13. #13

    Thread Starter
    New Member
    Join Date
    Dec 2008
    Posts
    12

    Re: Convert color images to black and white

    Hi Edgemeal

    I used the code which u sent to convert picturebox image to grayscale. With this I am able to convert the image to gray scale and save it. With this below code i am able to reduce only height and width when converting. My requirement is to convert a middle part of the image. Is it possible to convert a part of the image using the code you sent?

    Code:
    .biWidth = Picture1.ScaleX(Picture1.ScaleWidth - 4000, Picture1.ScaleMode, vbPixels)
                .biHeight = Picture1.ScaleY(Picture1.ScaleHeight - 4000, Picture1.ScaleMode, vbPixels)

  14. #14
    VB For Fun Edgemeal's Avatar
    Join Date
    Sep 2006
    Location
    WindowFromPoint
    Posts
    4,255

    Re: Convert color images to black and white

    Quote Originally Posted by mvr73
    Hi Edgemeal

    My requirement is to convert a middle part of the image. Is it possible to convert a part of the image using the code you sent?
    I tried this real quick on a picture and seems to work, I set the area in that last BitBlt call... don't really have time to study that code sorry,
    Code:
    ' Draw the greyscale image back to picture box 1
    BitBlt Picture1.hdc, 20, 20, _
    DIBInf.bmiHeader.biWidth - 40, _
    DIBInf.bmiHeader.biHeight - 40, _
    MyDC, 20, 20, vbSrcCopy
    EDIT It might be a tad faster if you set the area you wanted to modify to greyscale in both of those last two BitBlt calls.

    Code:
    ' Draw original picture to the greyscale DIB
    BitBlt MyDC, 20, 20, _
    DIBInf.bmiHeader.biWidth - 40, _
    DIBInf.bmiHeader.biHeight - 40, _
    Picture1.hdc, 20, 20, vbSrcCopy
    
    ' Draw the greyscale image back to picture box 1
    BitBlt Picture1.hdc, 20, 20, _
    DIBInf.bmiHeader.biWidth - 40, _
    DIBInf.bmiHeader.biHeight - 40, _
    MyDC, 20, 20, vbSrcCopy

    BTW, Mike D Sutton wrote those routines, has some good info on his site http://edais.mvps.org/

    To save as JPG I use a GDI+ routine.
    Last edited by Edgemeal; Dec 20th, 2008 at 02:12 PM.

  15. #15

    Thread Starter
    New Member
    Join Date
    Dec 2008
    Posts
    12

    Re: Convert color images to black and white

    Thanks for your help. It is working perfectly.

  16. #16
    New Member
    Join Date
    May 2016
    Posts
    1

    Re: Convert color images to black and white

    Hi

    Your solution was innovative and BRILLIANT.

    WELL DONE.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width