-
Dec 12th, 2008, 06:08 AM
#1
Thread Starter
New Member
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
-
Dec 12th, 2008, 06:57 AM
#2
Hyperactive Member
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..
-
Dec 12th, 2008, 07:11 AM
#3
Thread Starter
New Member
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
-
Dec 12th, 2008, 07:45 AM
#4
Hyperactive Member
Re: Convert color images to black and white
change
Picture1.PSet (XPos, YPos), NewColour
to
Picture1.PSet (j ,i), NewColour
and it should work
-
Dec 12th, 2008, 07:49 AM
#5
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.
-
Dec 12th, 2008, 07:54 AM
#6
Thread Starter
New Member
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.
-
Dec 12th, 2008, 07:59 AM
#7
Thread Starter
New Member
Re: Convert color images to black and white
I am not familiar with GetPixel and SetPixel. how to use these APIs
-
Dec 12th, 2008, 08:29 AM
#8
Hyperactive Member
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
-
Dec 12th, 2008, 11:31 AM
#9
Fanatic Member
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
-
Dec 12th, 2008, 12:58 PM
#10
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
-
Dec 15th, 2008, 01:53 AM
#11
Thread Starter
New Member
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?
-
Dec 16th, 2008, 03:04 AM
#12
Thread Starter
New Member
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 ?
-
Dec 17th, 2008, 02:03 AM
#13
Thread Starter
New Member
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)
-
Dec 20th, 2008, 01:37 PM
#14
Re: Convert color images to black and white
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.
-
Dec 22nd, 2008, 12:26 AM
#15
Thread Starter
New Member
Re: Convert color images to black and white
Thanks for your help. It is working perfectly.
-
May 5th, 2016, 12:44 AM
#16
New Member
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
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|