convert image 2

[jamesoc]

sorry to anyone who looked at my last thread it was all over the place
this i hope is more straight forward
I have a simple program to convert an image in a picture box into as grayscale image ,from what i have been told it is possible to then change that image in to a black and white image with certain levels of gray being converted to black and lower levels of gray being converted into white how would i do this
here is my code to change into gray scale
what would i need to add to this code



Private Sub cmdGray_Click()
Pic.ScaleMode = vbPixels
X = Pic.ScaleWidth
y = Pic.ScaleHeight
For i = 0 To y - 1
For j = 0 To X - 1
pixel = Pic.Point(j, i)
red = pixel Mod 256
green = ((pixel And &HFF00) / 256&) Mod 256&
blue = (pixel And &HFF0000) / 65536

gs = ((red * 30) + (green * 59) + (blue * 11)) / 100
Pic.PSet (j, i), RGB(gs, gs, gs)

Next
Next
Pic.ScaleMode = vbTwips
End Sub

 

[BobRodes]

I would try going through each pixel, finding its greyscale value, and changing it to black if it's over a certain number and white if it's under. Not that I could tell you what that number is, or exactly how to do it.

HTH

Bob

 

[Hypetia]

A simple choice is a 50% threshold, to decide between black and white, thus giving a value of 128 on a 0-255 scale. However, you can experiment further to find a value that suits your needs.

Note that there are functions in Windows API which transform colors from RGB to HSL color space and vice versa. You can convert a color from RGB to HSL and the Luminance component tells the shade of gray.
___
[tt]
Private Declare Sub ColorRGBToHLS Lib "shlwapi" (ByVal clrRGB As Long, pwHue As Integer, pwLuminance As Integer, pwSaturation As Integer)
Private Sub cmdGray_Click()
Dim I As Long, J As Long, X As Long, Y As Long
Dim H As Integer, S As Integer, L As Integer
Pic.ScaleMode = vbPixels
X = Pic.ScaleWidth
Y = Pic.ScaleHeight
For I = 0 To Y - 1
For J = 0 To X - 1
ColorRGBToHLS Pic.Point(J, I), H, L, S
L = L / 240 * 255 'scale-up from 240 to 255

'Pic.PSet (j, i), L * &H10101 'for grayscale
Pic.PSet (J, I), IIf(L < 128, vbBlack, vbWhite) 'for B&W
Next
Next
Pic.ScaleMode = vbTwips
End Sub[/tt]

 

[BobRodes]

Cool! Very interesting, thanks Hypetia.

Bob

 

[jamesoc]

thanks for the ideas guys but i did a bit of research and came up with this code from another guy.i put it in a command button and it works well .its also fairly easy to follow and doesnt need the original grayscale image to work


Private Sub Command1_Click()
Dim x As Long
Dim y As Long
Dim pixel As Long
Dim gs As Long ' Note this is a long now

Const COLOR_SPLIT As Long = &H80 '128
Const ONEBYTE As Long = &HFF '255

x = Pic.ScaleWidth
y = Pic.ScaleHeight

For y = 0 To y - 1
For x = 0 To x - 1
pixel = Pic.Point(x, y)
gs = -((pixel And ONEBYTE) \ COLOR_SPLIT)
Pic.PSet (x, y), gs ' If you switch to SetPixel(V) here, you'll need to And with &HFFFFFF, VB conveniently ignores the upper byte.
Next
Next

 

[strongm]

A search in this forum should find some dramtically fater methods of doing this

 

[johnwm]

Not only is it (very) slow but it only takes it luminance from the blue, so may not solve the original problem!

________________________________________________________________
If you want to get the best response to a question, please check out FAQ222-2244 first.
'If we're supposed to work in Hex, why have we only got A fingers?'
Drive a Steam Roller

 

[Hypetia]

>from the blue,
in fact, red.

strongm, I wanted to point them to our most recent discussion in thread222-1078537, but I see that that thread is also started by them and they also managed to get it working.

 

[johnwm]

Thank you Hypetia, I stand corrected. I had been playing with the code and trying different primary filters.

[off-topic]As was discovered in the '60s, you get better monochrome edges from the green channel in most 'earth-normal' lighting conditions (Philips worked on 'contours-out-of-green' in some of their early colour TV experiments)[/off-topic]

________________________________________________________________
If you want to get the best response to a question, please check out FAQ222-2244 first.
'If we're supposed to work in Hex, why have we only got A fingers?'
Drive a Steam Roller

 

[jamesoc]

i used hpetias code and it is quicker thanks .the problem with thread222-1078537 was that it didnt do what i was looking for it only converted to grayscale

 

[strongm]

Well, you should hacve said so in the thread ...

The ColorAdjustment code I gave there will do monochrome as well as grayscale; we just need modify two additional members of the COLORADJUSTMENT structure. I'll repeat the code here with the changes:

[blue]Option Explicit

Private Declare Function GetColorAdjustment Lib "gdi32" (ByVal hdc As Long, lpca As COLORADJUSTMENT) As Long
Private Declare Function SetColorAdjustment Lib "gdi32" (ByVal hdc As Long, lpca As COLORADJUSTMENT) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Type COLORADJUSTMENT
    caSize As Integer
    caFlags As Integer
    caIlluminantIndex As Integer
    caRedGamma As Integer
    caGreenGamma As Integer
    caBlueGamma As Integer
    caReferenceBlack As Integer
    caReferenceWhite As Integer
    caContrast As Integer
    caBrightness As Integer
    caColorfulness As Integer
    caRedGreenTint As Integer
End Type

Private Const HALFTONE = 4


Private Sub Form_Load()

End Sub

Private Sub Picture1_Click()
    Dim ca As COLORADJUSTMENT
    With Picture1
        .AutoRedraw = True
        .ScaleMode = vbPixels
        SetStretchBltMode .hdc, HALFTONE
        GetColorAdjustment .hdc, ca
        ca.caColorfulness = -100 'No colors!
        [b]ca.caReferenceBlack = 4000
        ca.caReferenceWhite = 6000[/b]
        SetColorAdjustment .hdc, ca
        StretchBlt .hdc, 0, 0, .ScaleWidth, .ScaleHeight, .hdc, 0, 0, .ScaleWidth, .ScaleHeight, vbSrcCopy
        .Refresh
    End With
End Sub
[/blue]

 

[Hypetia]

That was too good! Did not think about doing that. A star for you.

The above code still produced some shades of gray but they were also suppressed by maximizing the contrast.

[tt]ca.caContrast = 100[/tt]