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

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..

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

---

change
Picture1.PSet (XPos, YPos), NewColour


to
Picture1.PSet (j ,i), NewColour

and it should work

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

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

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

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

---

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

---

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

---

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?

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

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)

---

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.

Thanks for your help. It is working perfectly.

Hi

Your solution was innovative and BRILLIANT.

WELL DONE.