Trasformare un'immagine a colori in bianco e nero


Inserire il seguente codice in un modulo Bas:

Option Explicit

'matrice dei pixel dell'immagine a livelli di grigio
Public grayimage() As Byte
Public widthtwips As Long, heighttwips As Long

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

Public Sub GrayLevel(ByVal picMask As PictureBox)
    Dim widthpixels As Long, heightpixels As Long
    Dim width As Long, height As Long
    Dim pixel As Long
    Dim R As Long, G As Long, B As Long
    Dim I As Long, J As Long

    width = picMask.Picture.width
    widthtwips = picMask.ScaleX(width, vbHimetric, vbTwips)
    height = picMask.Picture.height
    heighttwips = picMask.ScaleY(height, vbHimetric, vbTwips)
    widthpixels = picMask.ScaleX(widthtwips, vbTwips, vbPixels)
    heightpixels = picMask.ScaleY(heighttwips, vbTwips, vbPixels)
    ReDim grayimage(widthpixels, heightpixels)
    For I = 0 To widthpixels - 1
        DoEvents
        For J = 0 To heightpixels - 1
            pixel = GetPixel(picMask.hdc, I, J)
            R = pixel And &HFF
            G = (pixel And &H100FF00) / 256
            B = (pixel And &HFF0000) / 65536
            grayimage(I, J) = R * 0.299 + G * 0.587 + B * 0.114
        Next J
    Next I
    OpenGrayImage picMask
End Sub

Public Sub OpenGrayImage(ByVal picMask As PictureBox)
    Dim I As Long, J As Long, Y As Double
    Dim ris As Long, gray As Long
    Dim Xpix As Long, Ypix As Long

    Xpix = UBound(grayimage, 1)
    Ypix = UBound(grayimage, 2)
    widthtwips = picMask.ScaleX(UBound(grayimage, 1), vbPixels, vbTwips)
    heighttwips = picMask.ScaleY(UBound(grayimage, 2), vbPixels, vbTwips)
    For I = 0 To UBound(grayimage, 1)
        DoEvents
        For J = 0 To UBound(grayimage, 2)
            gray = grayimage(I, J)
            Y = gray + (gray * 256#) + (gray * 65536#)
           
'per evitare l'overflow
            If Y > 2147483647 Then Y = 2147483647
            ris = SetPixel(picMask.hdc, I, J, Y)
        Next J
    Next I
End Sub

In un Form inserisci un CommandButton ed una PictureBox ed il seguente codice:

Private Sub Command1_Click()
    GrayLevel Picture1
End Sub

Se vuoi ripristinare l'immagine a colori inserisci un'atra PictureBox ed un'altro CommandButton.

Infine inserisci il seguente codice:

Private Sub Command2_Click()
    Picture1.Picture = Picture2.Image
End Sub

Private Sub Form_Load()
    Picture2.Picture = Picture1.Image
End Sub

Testato su: Windows 98, Win Me, Windows 2000 Professional