Fast GreyScaling Using Byte Arrays

Category:

Screen/Graphics

Type:

Snippets

Difficulty:

Intermediate

Author: neophile

Version Compatibility: Visual Basic 6, Visual Basic 5

More information:

Here are two functions that use DIBs and byte arrays to quickly greyscale images. Bit24ToGrey24 will greyscale a picture for display purposes and Bit24ToGrey8File will greyscale a picture directly to a 256-color bitmap file. Here are examples of each: Picture2.Picture = Bit24ToGrey24(Picture1.Picture) Bit24ToGrey8File(Picture1.Picture, "C:\grey256.bmp") This code uses the ITU standard greyscaling alogrithm, but here are all the notorious ones... International Telecommunications Union standard - recommended Shade = (0.2125 * Red + 0.7154 * Green + 0.0721 * Blue) NTSC and PAL Shade = (0.299 * Red + 0.587 * Green + 0.114 * Blue) Simple average Shade = (Red + Green + Blue) / 3 Weighted average - common Shade = (3 * Red + 4 * Green + 2 * Blue) / 9 Distance of color vector in color cube - not recommended Shade = Sqr((Red ^ 2 + Green ^ 2 + Blue ^ 2) / 3) Human eye responsive - not recommended (ignores red & blue) Shade = Green Anyway, enjoy ;)

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
Option Explicit Private Type BITMAPINFO Size As Long Width As Long Height As Long Planes As Integer BitCount As Integer Compression As Long SizeImage As Long XPelsPerMeter As Long YPelsPerMeter As Long ClrUsed As Long ClrImportant As Long End Type Private Type RGBQUAD Blue As Byte Green As Byte Red As Byte Reserved As Byte End Type Private Type BITMAP Type As Long Width As Long Height As Long WidthBytes As Long Planes As Integer BitsPixel As Integer Bits As Long End Type Private Type BITMAPFILEHEADER Type As String * 2 Size As Long Reserved1 As Integer Reserved2 As Integer OffBits As Long End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Type PicBmp Size As Long Type As Long hBmp As Long hPal As Long Reserved As Long End Type Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal imageType As Long, ByVal NewWidth As Long, ByVal NewHeight As Long, ByVal lFlags As Long) As Long Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Code:

Public Function Bit24toGrey24(ByVal Image As Long) As Picture
    Dim vBMP As BITMAP
    Dim lBmp As Long
    Dim lDC As Long
    Dim vBMI As BITMAPINFO
    Dim bBits() As Byte
    Dim iPad As Integer
    Dim lX As Long
    Dim lY As Long
    Dim lP As Long
    Dim iId As Long
    Dim bFile As Boolean
    
    Call GetObject(Image, Len(vBMP), vBMP)
    If vBMP.BitsPixel = 24 Then
        lBmp = CopyImage(Image, 0, 0, 0, 0)
        lDC = CreateCompatibleDC(0)
        With vBMI
            .BitCount = 24
            .Width = vBMP.Width
            .Height = vBMP.Height
            .Planes = vBMP.Planes
            .Size = Len(vBMI)
        End With
        iPad = CalcPadding(vBMP.Width, 24)
        ReDim bBits((((vBMP.Width * 3) + iPad) * vBMP.Height) - 1)
        Call SelectObject(lDC, lBmp)
        Call GetDIBits(lDC, lBmp, 0, vBMP.Height, bBits(0), vBMI, 0)
        For lY = 0 To vBMP.Height - 1
        For lX = 0 To vBMP.Width - 1
            lP = (lY * ((vBMP.Width * 3) + iPad)) + (lX * 3)
            iId = (0.2125 * bBits(lP + 2) + 0.7154 * bBits(lP + 1) + 0.0721 * bBits(lP))
            bBits(lP + 2) = iId
            bBits(lP + 1) = iId
            bBits(lP) = iId
        Next
        Next
        Call SetDIBitsToDevice(lDC, 0, 0, vBMP.Width, vBMP.Height, 0, 0, 0, vBMP.Height, bBits(0), vBMI, 0)
        Set Bit24toGrey24 = ConvertToPicture(lBmp)
        DeleteDC lDC
    End If
End Function

Public Function Bit24ToGrey8File(ByVal Image As Long, ByVal Filename As String) As Boolean
    Dim vBMP As BITMAP
    Dim lBmp As Long
    Dim lDC As Long
    Dim vBMI As BITMAPINFO
    Dim bBits() As Byte
    Dim bBits8() As Byte
    Dim iPad As Integer
    Dim iPad8 As Integer
    Dim lX As Long
    Dim lY As Long
    Dim lP As Long
    Dim iId As Long
    Dim vPal() As RGBQUAD
    Dim vBMF As BITMAPFILEHEADER
    Dim fn As Integer
    
    Call GetObject(Image, Len(vBMP), vBMP)
    If vBMP.BitsPixel = 24 Then
        lBmp = CopyImage(Image, 0, 0, 0, 0)
        lDC = CreateCompatibleDC(0)
        With vBMI
            .BitCount = 24
            .Width = vBMP.Width
            .Height = vBMP.Height
            .Planes = vBMP.Planes
            .Size = Len(vBMI)
        End With
        iPad = CalcPadding(vBMP.Width, 24)
        iPad8 = CalcPadding(vBMP.Width, 8)
        ReDim bBits((((vBMP.Width * 3) + iPad) * vBMP.Height) - 1)
        ReDim bBits8(((vBMP.Width + iPad8) * vBMP.Height) - 1)
        Call SelectObject(lDC, lBmp)
        Call GetDIBits(lDC, lBmp, 0, vBMP.Height, bBits(0), vBMI, 0)
        For lY = 0 To vBMP.Height - 1
        For lX = 0 To vBMP.Width - 1
            lP = (lY * ((vBMP.Width * 3) + iPad)) + (lX * 3)
            iId = (0.2125 * bBits(lP + 2) + 0.7154 * bBits(lP + 1) + 0.0721 * bBits(lP))
            bBits8(lY * (vBMP.Width + iPad) + lX) = iId
        Next
        Next
        DeleteDC lDC
        DeleteObject lBmp
        Erase bBits
        ReDim vPal(255)
        For lX = 0 To 255
            With vPal(lX)
                .Red = lX
                .Green = lX
                .Blue = lX
            End With
        Next
        With vBMI
            .BitCount = 8
            .ClrUsed = 256
            .ClrImportant = 256
            .SizeImage = UBound(bBits8) + 1
        End With
        With vBMF
            .Type = "BM"
            .OffBits = Len(vBMI) + Len(vBMF) + ((UBound(vPal) + 1) * 4)
            .Size = .OffBits + vBMI.SizeImage
        End With
        fn = FreeFile
        Open Filename For Binary Lock Write As fn
            Put fn, , vBMF
            Put fn, , vBMI
            Put fn, , vPal
            Put fn, , bBits8
        Close fn
        Erase vPal
        Erase bBits8
        Bit24ToGrey8File = True
    End If
End Function

Private Function CalcPadding(ByVal Width As Long, ByVal BitsPixel As Integer) As Integer
    CalcPadding = (32 - ((Width * BitsPixel) Mod 32))
    If CalcPadding = 32 Then CalcPadding = 0
    CalcPadding = CalcPadding \ BitsPixel
End Function

Private Function ConvertToPicture(ByVal Image As Long) As Picture
    Dim vIDispatch As GUID
    Dim vPic As PicBmp
    
    With vIDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With vPic
        .Size = Len(vPic)
        .Type = vbPicTypeBitmap
        .hBmp = Image
    End With
    Call OleCreatePictureIndirect(vPic, vIDispatch, 1, ConvertToPicture)
End Function