vbAccelerator - Contents of code file: cImageProcessDIB.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cColourReduceDIB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'
 ===============================================================================
===
' cColourReduceDIB.cls
' Copyright  1999 Steve McMahon
' Visit vbAccelerator at http://vbaccelerator.com
'
' Provides functions for colour reduction of a cDIBSection
' object:
'  * Floyd-Stucci colour reduction to BW & Arbitrary Palettes
'  * Optimal Palette Generation using Octree-Colour Quantisation
'  * Grey Scaling
'
'
 ===============================================================================
===

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr()
 As Any) As Long

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Public Event InitProgress(ByVal lMax As Long)
Public Event Progress(ByVal lPosition As Long)
Public Event Complete(ByVal lTimeMs As Long)

Private Type tPalItem
   rgbRed As Byte
   rgbGreen As Byte
   rgbBlue As Byte
   lColorRef As Long
End Type
   

Public Sub BlackAndWhite( _
        ByRef cFrom As cDIBSection, _
        ByRef cTo As cDIBSection _
    )
' Converts to Black and WHite using Floyd-Steinberg error diffusion
' process.
' see http://www.dcs.ed.ac.uk/~mxr/gfx/faqs/colourspace.faq for details.
'
Dim pict() As Byte
Dim pict2() As Byte
Dim sa As SAFEARRAY2D
Dim sa2 As SAFEARRAY2D
Dim x As Long, y As Long
Dim i As Long, iCoeff As Long
Dim lTIme As Long
Dim xMax As Long, yMax As Long
Dim lError As Long
Dim lNew As Long
Dim iC As Long, iC2 As Long

    lTIme = timeGetTime()
       
    GrayScale cFrom
       
    ' have the local matrix point to bitmap pixels
    With sa
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cTo.BytesPerScanLine
        .pvData = cTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
    ' Pict now stores the To buffer
        
    ' have the local matrix point to bitmap pixels
    With sa2
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cFrom.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cFrom.BytesPerScanLine
        .pvData = cFrom.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict2), VarPtr(sa2), 4
    ' Pict2 now stores the From buffer


    yMax = cTo.Height - 1
    xMax = (cTo.Width - 1) * 3
    
    RaiseEvent InitProgress(xMax)
    For x = 0 To xMax Step 3
        For y = 0 To yMax
            ' Apply a simple threshold:
            If (pict2(x, y) > 128) Then
                iC = iC + 1
                pict(x, y) = 255
                pict(x + 1, y) = 255
                pict(x + 2, y) = 255
                lError = (255 - pict2(x, y)) - 128
            Else
                iC2 = iC2 + 1
                pict(x, y) = 0
                pict(x + 1, y) = 0
                pict(x + 2, y) = 0
                ' Black tolerance:
                If (pict2(x, y) > 16) Then
                    lError = pict2(x, y)
                Else
                    lError = 0
                End If
            End If
            
            ' Diffuse the error:
            If (x < xMax - 3) Then
                lNew = pict2(x + 3, y) + (lError * 7) \ 16
                If (lNew > 255) Then lNew = 255
                If (lNew < 0) Then lNew = 0
                pict2(x + 3, y) = lNew
                pict2(x + 4, y) = lNew
                pict2(x + 5, y) = lNew
            End If
            If (y < yMax) Then
                For i = -3 To 3 Step 3
                    If (x + i) > 0 And (x + i) < xMax Then
                        Select Case i
                        Case -3
                            iCoeff = 3
                        Case 0
                            iCoeff = 5
                        Case 3
                            iCoeff = 1
                        End Select
                        lNew = pict2(x + i, y + 1) + (lError * iCoeff) \ 16
                        If (lNew > 255) Then lNew = 255
                        If (lNew < 0) Then lNew = 0
                        pict2(x + i, y + 1) = lNew
                        pict2(x + i + 1, y + 1) = lNew
                        pict2(x + i + 2, y + 1) = lNew
                    End If
                Next i
            End If
        Next y
        RaiseEvent Progress(x)
    Next x
    
    ' clear the temporary array descriptor
    ' without destroying the local temporary array
    CopyMemory ByVal VarPtrArray(pict), 0&, 4
    CopyMemory ByVal VarPtrArray(pict2), 0&, 4
    
    cFrom.LoadPictureBlt cTo.hdc
    RaiseEvent Complete(timeGetTime - lTIme)
    
    
End Sub

Public Sub ApplyPalette( _
      ByRef cFrom As cDIBSection, _
      ByRef cTo As cDIBSection, _
      ByRef cPal As cPalette, _
      Optional ByVal bDiffuseError As Boolean = True _
   )
'
Dim pict() As Byte
Dim pict2() As Byte
Dim sa As SAFEARRAY2D
Dim sa2 As SAFEARRAY2D
Dim x As Long, y As Long
Dim i As Long, iCoeff As Long, j As Long
Dim lTIme As Long
Dim xMax As Long, yMax As Long
Dim lErrorRed As Long, lErrorBlue As Long, lErrorGreen As Long
Dim lNewRed As Long, lNewBlue As Long, lNewGreen As Long
Dim lIndex As Long
Dim iC As Long, iC2 As Long


    lTIme = timeGetTime()
       
    ' have the local matrix point to bitmap pixels
    With sa
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cTo.BytesPerScanLine
        .pvData = cTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
    ' Pict now stores the To buffer
        
    ' have the local matrix point to bitmap pixels
    With sa2
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cFrom.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cFrom.BytesPerScanLine
        .pvData = cFrom.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict2), VarPtr(sa2), 4
    ' Pict2 now stores the From buffer
   
    yMax = cTo.Height - 1
    xMax = (cTo.Width - 1) * 3
    
    RaiseEvent InitProgress(xMax)
    For x = 0 To xMax Step 3
        For y = 0 To yMax
            ' Get nearest colour:
            
            lIndex = cPal.ClosestIndex(pict2(x + 2, y), pict2(x + 1, y),
             pict2(x, y))
                                 
            pict(x + 2, y) = cPal.Red(lIndex)
            pict(x + 1, y) = cPal.Green(lIndex)
            pict(x, y) = cPal.Blue(lIndex)
                        
            If bDiffuseError Then
               lErrorRed = -1 * (CLng(pict(x + 2, y)) - pict2(x + 2, y))
               lErrorGreen = -1 * (CLng(pict(x + 1, y)) - pict2(x + 1, y))
               lErrorBlue = -1 * (CLng(pict(x, y)) - pict2(x, y))
               
               ' Diffuse the error:
               'Debug.Print lErrorRed, lErrorGreen, lErrorBlue
               If Abs(lErrorRed) + Abs(lErrorGreen) + Abs(lErrorBlue) > 3 Then
                  If (x < xMax - 3) Then
                      lNewBlue = pict2(x + 3, y) + (lErrorBlue * 7) \ 16
                      lNewGreen = pict2(x + 4, y) + (lErrorGreen * 7) \ 16
                      lNewRed = pict2(x + 5, y) + (lErrorRed * 7) \ 16
                      Range lNewBlue, 0, 255
                      Range lNewGreen, 0, 255
                      Range lNewRed, 0, 255
                      pict2(x + 3, y) = lNewBlue
                      pict2(x + 4, y) = lNewGreen
                      pict2(x + 5, y) = lNewRed
                  End If
                  If (y < yMax) Then
                      For i = -3 To 3 Step 3
                          If (x + i) > 0 And (x + i) < xMax Then
                              Select Case i
                              Case -3
                                  iCoeff = 0
                              Case 0
                                  iCoeff = 4
                              Case 3
                                  iCoeff = 0
                              End Select
                              lNewBlue = pict2(x + i, y + 1) + (lErrorBlue *
                               iCoeff) \ 16
                              lNewGreen = pict2(x + i + 1, y + 1) +
                               (lErrorGreen * iCoeff) \ 16
                              lNewRed = pict2(x + i + 2, y + 1) + (lErrorRed *
                               iCoeff) \ 16
                              Range lNewBlue, 0, 255
                              Range lNewGreen, 0, 255
                              Range lNewRed, 0, 255
                              pict2(x + i, y + 1) = lNewBlue
                              pict2(x + i + 1, y + 1) = lNewGreen
                              pict2(x + i + 2, y + 1) = lNewRed
                          End If
                      Next i
                  End If
               End If
            End If
        Next y
        RaiseEvent Progress(x)
    Next x
    
    ' clear the temporary array descriptor
    ' without destroying the local temporary array
    CopyMemory ByVal VarPtrArray(pict), 0&, 4
    CopyMemory ByVal VarPtrArray(pict2), 0&, 4
    
    Debug.Print iC, iC2
    cFrom.LoadPictureBlt cTo.hdc
    RaiseEvent Complete(timeGetTime - lTIme)
    
    
End Sub
   
Private Sub Range( _
      ByRef lIn As Long, _
      ByVal lMin As Long, _
      ByVal lMax As Long _
   )
   If (lIn < lMin) Then
      lIn = lMin
   ElseIf (lIn > lMax) Then
      lIn = lMax
   End If
End Sub

Public Sub GrayScale( _
        ByRef cTo As cDIBSection _
    )
' Gray scale using standard intensity components.
' see http://www.dcs.ed.ac.uk/~mxr/gfx/faqs/colourspace.faq for details.
'
Dim bDib() As Byte
Dim x As Long, y As Long
Dim xMax As Long, yMax As Long
Dim bContinue As Boolean
Dim lB As Long, lG As Long, lR As Long
Dim lGray As Long
Dim lTIme As Long
Dim tSA As SAFEARRAY2D

    lTIme = timeGetTime()
        
    ' have the local matrix point to bitmap pixels
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cTo.BytesPerScanLine
        .pvData = cTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bDib), VarPtr(tSA), 4
        
    yMax = cTo.Height - 1
    xMax = cTo.Width - 1
    
    RaiseEvent InitProgress(xMax)
    For x = 0 To (xMax * 3) Step 3
        For y = 0 To yMax
            lB = bDib(x, y)
            lG = bDib(x + 1, y)
            lR = bDib(x + 2, y)
                
            'But now all people *should* use the most accurate, it means ITU
             standard:
            lGray = (222 * lR + 707 * lG + 71 * lB) / 1000
            
            bDib(x, y) = lGray
            bDib(x + 1, y) = lGray
            bDib(x + 2, y) = lGray
        Next y
        RaiseEvent Progress(x)
    Next x
    
    ' clear the temporary array descriptor
    ' without destroying the local temporary array
    CopyMemory ByVal VarPtrArray(bDib), 0&, 4
    
    RaiseEvent Complete(timeGetTime - lTIme)
    
End Sub