vbAccelerator - Contents of code file: cDibQuantiser.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cDibQuantiser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

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 "msvbvm60.dll" Alias "VarPtr" (Ptr()
 As Any) As Long
Private Declare Function GetPixelAPI Lib "gdi32" Alias "GetPixel" (ByVal hDC As
 Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1


Private m_cQuantiseStripOrig As cAlphaDibSection
Private m_cQuantiseStripScaled As cAlphaDibSection
Private m_cSourceImage As cAlphaDibSection
Private m_cDestImage As cAlphaDibSection

Private m_lQuantiseImages As Long
Private m_lQuantiseImageScale As Long
Private m_lPixelsPerBlock As Long

Private m_bKeepColours As Boolean
Private m_bApplyQuantisedLuminance As Boolean

Private m_oTransColor As OLE_COLOR

Public Property Get KeepColours() As Boolean
   KeepColours = m_bKeepColours
End Property
Public Property Let KeepColours(ByVal bState As Boolean)
   m_bKeepColours = bState
End Property
Public Property Get ApplyQuantisedLuminance() As Boolean
   ApplyQuantisedLuminance = m_bApplyQuantisedLuminance
End Property
Public Property Let ApplyQuantisedLuminance(ByVal bState As Boolean)
   m_bApplyQuantisedLuminance = bState
End Property

Public Sub Apply()
Dim lXPosition() As Long

   pCreateOutputImage

   ReDim lXPosition(0 To 255) As Long
   pCreateGreyScaleArray lXPosition

   pQuantise lXPosition

End Sub

Private Sub pQuantise(lXPosition() As Long)

Dim tSA As SAFEARRAY2D
Dim tSATo As SAFEARRAY2D
Dim tSAStrip As SAFEARRAY2D
Dim bDib() As Byte
Dim bDibTo() As Byte
Dim bDibStrip() As Byte
Dim xFrom As Long
Dim yFrom As Long
Dim xFromAvg As Long
Dim yFromAvg As Long
Dim xTo As Long
Dim yTo As Long
Dim xFromStep As Long
Dim yFromStep As Long
Dim xToStep As Long
Dim yToStep As Long
Dim xToOrig As Long
Dim yToOrig As Long
Dim xStrip As Long
Dim yStrip As Long
Dim xStripEnd As Long
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
Dim lGrey As Long
Dim lRedAverage As Long
Dim lGreenAverage As Long
Dim lBlueAverage As Long
Dim lGreyAverage As Long
Dim lSamples As Long
Dim lAverage As Long
Dim h As Single
Dim s As Single
Dim l As Single
Dim hStrip As Single
Dim sStrip As Single
Dim lStrip As Single
Dim lRedOut As Long
Dim lGreenOut As Long
Dim lBlueOut As Long

   With tSA
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = m_cSourceImage.Height
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = m_cSourceImage.BytesPerScanLine()
      .pvData = m_cSourceImage.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
    
   With tSATo
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = m_cDestImage.Height
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = m_cDestImage.BytesPerScanLine()
      .pvData = m_cDestImage.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDibTo()), VarPtr(tSATo), 4

   With tSAStrip
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = m_cQuantiseStripScaled.Height
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = m_cQuantiseStripScaled.BytesPerScanLine()
      .pvData = m_cQuantiseStripScaled.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDibStrip()), VarPtr(tSAStrip), 4


   xFromStep = m_lPixelsPerBlock * 4
   yFromStep = m_lPixelsPerBlock
   xToStep = (m_cQuantiseStripScaled.Width \ m_lQuantiseImages) * 4
   yToStep = m_cQuantiseStripScaled.Height
   
   
   For xFrom = 0 To tSA.Bounds(1).cElements - 1 Step xFromStep
      For yFrom = 0 To tSA.Bounds(0).cElements - 1 Step yFromStep
      
         lGreyAverage = 0
         lRedAverage = 0
         lGreenAverage = 0
         lBlueAverage = 0
         lSamples = 0
         For xFromAvg = xFrom To xFrom + xFromStep - 1 Step 4
            If (xFromAvg > tSA.Bounds(1).cElements - 1) Then
               Exit For
            End If
            For yFromAvg = yFrom To yFrom + yFromStep - 1
               If (yFromAvg > tSA.Bounds(0).cElements - 1) Then
                  Exit For
               End If
               
               lSamples = lSamples + 1
               lRed = bDib(xFromAvg + 2, yFromAvg)
               lGreen = bDib(xFromAvg + 1, yFromAvg)
               lBlue = bDib(xFromAvg, yFromAvg)
               lGrey = (222 * lRed + 707 * lGreen + 71 * lBlue) / 1000
               lRedAverage = lRedAverage + lRed
               lGreenAverage = lGreenAverage + lGreen
               lBlueAverage = lBlueAverage + lBlue
               lGreyAverage = lGreyAverage + lGrey
               
            Next yFromAvg
         Next xFromAvg
               
         ' Copy the appropriate image
         lAverage = lGreyAverage \ lSamples
         lRedAverage = lRedAverage \ lSamples
         lGreenAverage = lGreenAverage \ lSamples
         lBlueAverage = lBlueAverage \ lSamples
         
         xStripEnd = lXPosition(lAverage) + xToStep
         xToOrig = xTo
         yToOrig = yTo
         For xStrip = lXPosition(lAverage) To xStripEnd - 4 Step 4
            If (xTo > tSATo.Bounds(1).cElements - 1) Then
               Exit For
            End If
            For yStrip = 0 To tSAStrip.Bounds(0).cElements - 1
               If (yTo > tSATo.Bounds(0).cElements - 1) Then
                  Exit For
               End If
               If (m_bKeepColours) Then
                  ' Colourise the source colour to the destination
                  ' colour
                  RGBToHLS lRedAverage, lGreenAverage, lBlueAverage, h, s, l
                  If (m_bApplyQuantisedLuminance) Then
                     RGBToHLS bDibStrip(xStrip + 2, yStrip), bDibStrip(xStrip +
                      1, yStrip), bDibStrip(xStrip, yStrip), hStrip, sStrip,
                      lStrip
                     l = l * lStrip
                     If (l > 1#) Then l = 1#
                  End If
                  HLSToRGB h, s, l, lRedOut, lGreenOut, lBlueOut
                  bDibTo(xTo, yTo) = lBlueOut * bDibStrip(xStrip + 3, yStrip) \
                   255
                  bDibTo(xTo + 1, yTo) = lGreenOut * bDibStrip(xStrip + 3,
                   yStrip) \ 255
                  bDibTo(xTo + 2, yTo) = lRedOut * bDibStrip(xStrip + 3,
                   yStrip) \ 255
                  bDibTo(xTo + 3, yTo) = bDibStrip(xStrip + 3, yStrip)
               Else
                  bDibTo(xTo, yTo) = bDibStrip(xStrip, yStrip)
                  bDibTo(xTo + 1, yTo) = bDibStrip(xStrip + 1, yStrip)
                  bDibTo(xTo + 2, yTo) = bDibStrip(xStrip + 2, yStrip)
                  bDibTo(xTo + 3, yTo) = bDibStrip(xStrip + 3, yStrip)
               End If
               yTo = yTo + 1
            Next yStrip
            xTo = xTo + 4
            yTo = yToOrig
         Next xStrip
         xTo = xToOrig
         
         yTo = yTo + yToStep
      Next yFrom
      xTo = xTo + xToStep
      yTo = 0
   Next xFrom
   
   

   ' Clear the temporary array descriptor
   ' (This does not appear to be necessary, but
   ' for safety do it anyway)
   CopyMemory ByVal VarPtrArray(bDibStrip), 0&, 4
   CopyMemory ByVal VarPtrArray(bDibTo), 0&, 4
   CopyMemory ByVal VarPtrArray(bDib), 0&, 4


End Sub

Private Sub pCreateOutputImage()
Dim lWidth As Long
Dim lHeight As Long

   If Not (m_cSourceImage Is Nothing) And Not (m_cQuantiseStripScaled Is
    Nothing) Then
      lWidth = (m_cSourceImage.Width * m_cQuantiseStripScaled.Width \
       m_lQuantiseImages) \ m_lPixelsPerBlock
      lHeight = (m_cSourceImage.Height * m_cQuantiseStripScaled.Height) \
       m_lPixelsPerBlock
      
      Set m_cDestImage = New cAlphaDibSection
      m_cDestImage.Create lWidth, lHeight
   End If
      
End Sub

Private Sub pCreateGreyScaleArray(lXPosition() As Long)
Dim x As Long
Dim i As Long
Dim xSize As Long
Dim quantiseStep As Long
   
   xSize = m_cQuantiseStripScaled.Width \ m_lQuantiseImages
   quantiseStep = 256 \ m_lQuantiseImages
   x = 0
   For i = 0 To 255
      lXPosition(i) = x * 4
      If (i > 0) Then
         If (i Mod quantiseStep) = 0 Then
            x = x + xSize
         End If
      End If
   Next i
   
End Sub

Public Property Get PixelsPerBlock() As Long
   PixelsPerBlock = m_lPixelsPerBlock
End Property
Public Property Let PixelsPerBlock(ByVal lPixels As Long)
   If (lPixels <= 0) Then
      Err.Raise 5, "Pixels per block must be greater than 0"
   Else
      m_lPixelsPerBlock = lPixels
      pCreateOutputImage
   End If
End Property

Public Property Get ImageStripImageCount() As Long
   ImageStripImageCount = m_lQuantiseImages
End Property
Public Property Let ImageStripImageCount(ByVal lCount As Long)
   If (lCount <= 0) Then
      Err.Raise 5, "Number of images must be greater than 0"
   ElseIf (lCount > 128) Then
      Err.Raise 5, "Number of images cannot exceed 128"
   Else
      m_lQuantiseImages = lCount
   End If
End Property

Public Property Get ImageStripScale() As Long
   ImageStripScale = m_lQuantiseImageScale
End Property
Public Property Let ImageStripScale(ByVal lScale As Long)
   If (lScale > 0) Then
      m_lQuantiseImageScale = lScale
      pCreateQuantisedImage
   Else
      Err.Raise 5, "Scale must be greater than 0"
   End If
End Property

Public Property Get ScaledImageStrip() As cAlphaDibSection
   Set ScaledImageStrip = m_cQuantiseStripScaled
End Property

Public Property Get SourceImageStrip() As cAlphaDibSection
   Set SourceImageStrip = m_cQuantiseStripOrig
End Property
Public Sub LoadAlphaBitmapImageStrip()

End Sub

Public Sub LoadImageStrip(sPic As StdPicture)
      
   Set m_cQuantiseStripOrig = New cAlphaDibSection
   m_cQuantiseStripOrig.CreateFromPicture sPic
   If (m_cQuantiseStripOrig.AreAllAlphaBytesZero) Then
      Dim lTransColor As Long
      If (m_oTransColor = -1) Then
         lTransColor = GetPixelAPI(m_cQuantiseStripOrig.hDC,
          m_cQuantiseStripOrig.Width - 1, 0)
      Else
         OleTranslateColor m_oTransColor, 0, lTransColor
      End If
      m_cQuantiseStripOrig.SetColourTransparent lTransColor, 255
   End If
   pCreateQuantisedImage

End Sub

Public Property Get ImageStripTransparentColor() As OLE_COLOR
   If (m_oTransColor = -1) Then
      ImageStripTransparentColor = GetPixelAPI(m_cQuantiseStripOrig.hDC,
       m_cQuantiseStripOrig.Width - 1, 0)
   Else
      ImageStripTransparentColor = m_oTransColor
   End If
End Property
Public Property Let ImageStripTransparentColor(ByVal oColor As OLE_COLOR)
   m_oTransColor = oColor
End Property

Private Sub pCreateQuantisedImage()
Dim lNewWidth As Long
Dim lTransColor As Long
   If Not (m_cQuantiseStripOrig Is Nothing) Then
      If (m_lQuantiseImageScale = 1) Then
         Set m_cQuantiseStripScaled = m_cQuantiseStripOrig.Clone()
         OleTranslateColor ImageStripTransparentColor, 0, lTransColor
         m_cQuantiseStripScaled.SetColourTransparent lTransColor, , True
      Else
         lNewWidth = m_cQuantiseStripOrig.Width \ m_lQuantiseImageScale
         Set m_cQuantiseStripScaled =
          m_cQuantiseStripOrig.AlphaResample(lNewWidth)
      End If
   End If
End Sub

Public Property Get SourceImage() As cAlphaDibSection
   Set SourceImage = m_cSourceImage
End Property

Public Sub LoadImage(sPic As StdPicture)
   Set m_cSourceImage = New cAlphaDibSection
   m_cSourceImage.CreateFromPicture sPic
   If (m_cSourceImage.AreAllAlphaBytesZero) Then
      m_cSourceImage.SetAlpha 255
   End If
End Sub

Public Property Get ResultImage() As cAlphaDibSection
   Set ResultImage = m_cDestImage
End Property

Public Sub RGBToHLS( _
      ByVal r As Long, ByVal g As Long, ByVal b As Long, _
      h As Single, s As Single, l As Single _
   )
Dim Max As Single
Dim Min As Single
Dim delta As Single
Dim rR As Single, rG As Single, rB As Single

   rR = r / 255: rG = g / 255: rB = b / 255

'{Given: rgb each in [0,1].
' Desired: h in [0,360] and s in [0,1], except if s=0, then h=UNDEFINED.}
        Max = Maximum(rR, rG, rB)
        Min = Minimum(rR, rG, rB)
        l = (Max + Min) / 2    '{This is the lightness}
        '{Next calculate saturation}
        If Max = Min Then
            'begin {Acrhomatic case}
            s = 0
            h = 0
           'end {Acrhomatic case}
        Else
           'begin {Chromatic case}
                '{First calculate the saturation.}
           If l <= 0.5 Then
               s = (Max - Min) / (Max + Min)
           Else
               s = (Max - Min) / (2 - Max - Min)
            End If
            '{Next calculate the hue.}
            delta = Max - Min
           If rR = Max Then
                h = (rG - rB) / delta    '{Resulting color is between yellow
                 and magenta}
           ElseIf rG = Max Then
                h = 2 + (rB - rR) / delta '{Resulting color is between cyan and
                 yellow}
           ElseIf rB = Max Then
                h = 4 + (rR - rG) / delta '{Resulting color is between magenta
                 and cyan}
            End If
            'Debug.Print h
            'h = h * 60
           'If h < 0# Then
           '     h = h + 360            '{Make degrees be nonnegative}
           'End If
        'end {Chromatic Case}
      End If
'end {RGB_to_HLS}
End Sub

Public Sub HLSToRGB( _
      ByVal h As Single, ByVal s As Single, ByVal l As Single, _
      r As Long, g As Long, b As Long _
   )
Dim rR As Single, rG As Single, rB As Single
Dim Min As Single, Max As Single

   If s = 0 Then
      ' Achromatic case:
      rR = l: rG = l: rB = l
   Else
      ' Chromatic case:
      ' delta = Max-Min
      If l <= 0.5 Then
         's = (Max - Min) / (Max + Min)
         ' Get Min value:
         Min = l * (1 - s)
      Else
         's = (Max - Min) / (2 - Max - Min)
         ' Get Min value:
         Min = l - s * (1 - l)
      End If
      ' Get the Max value:
      Max = 2 * l - Min
      
      ' Now depending on sector we can evaluate the h,l,s:
      If (h < 1) Then
         rR = Max
         If (h < 0) Then
            rG = Min
            rB = rG - h * (Max - Min)
         Else
            rB = Min
            rG = h * (Max - Min) + rB
         End If
      ElseIf (h < 3) Then
         rG = Max
         If (h < 2) Then
            rB = Min
            rR = rB - (h - 2) * (Max - Min)
         Else
            rR = Min
            rB = (h - 2) * (Max - Min) + rR
         End If
      Else
         rB = Max
         If (h < 4) Then
            rR = Min
            rG = rR - (h - 4) * (Max - Min)
         Else
            rG = Min
            rR = (h - 4) * (Max - Min) + rG
         End If
         
      End If
            
   End If
   r = rR * 255: g = rG * 255: b = rB * 255
End Sub
Private Function Maximum(rR As Single, rG As Single, rB As Single) As Single
   If (rR > rG) Then
      If (rR > rB) Then
         Maximum = rR
      Else
         Maximum = rB
      End If
   Else
      If (rB > rG) Then
         Maximum = rB
      Else
         Maximum = rG
      End If
   End If
End Function
Private Function Minimum(rR As Single, rG As Single, rB As Single) As Single
   If (rR < rG) Then
      If (rR < rB) Then
         Minimum = rR
      Else
         Minimum = rB
      End If
   Else
      If (rB < rG) Then
         Minimum = rB
      Else
         Minimum = rG
      End If
   End If
End Function


Private Sub Class_Initialize()
   m_lPixelsPerBlock = 4
   m_oTransColor = -1
End Sub