vbAccelerator - Contents of code file: cAlphaImageCreator.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 = "cAlphaImageCreator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
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 m_cMask As New cAlphaDibSection
Private m_cImage As New cAlphaDibSection
Private m_cAlphaImage As New cAlphaDibSection

Public Property Get AlphaChannel() As cAlphaDibSection
   Set AlphaChannel = m_cMask
End Property

Public Property Get Image() As cAlphaDibSection
   Set Image = m_cImage
End Property

Public Property Get AlphaImage() As cAlphaDibSection
   Set AlphaImage = m_cAlphaImage
End Property

Public Sub CreateAlphaImage()

   Dim lWidth As Long
   Dim lHeight As Long
   
   lWidth = IIf(m_cImage.Width > m_cMask.Width, m_cMask.Width, m_cImage.Width)
   lHeight = IIf(m_cImage.Height > m_cMask.Height, m_cMask.Height,
    m_cImage.Height)
   
   If (lWidth <= 0) Or (lHeight <= 0) Then
      Exit Sub
   End If
      
   ' Create a new image, which is just a copy of the picture
   ' in m_cImage to build the alpha version in.  Note if
   ' we didn't want to display the image without alpha later,
   ' we could just work on m_cImage directly instead.
   m_cAlphaImage.Create lWidth, lHeight
   m_cImage.PaintPicture m_cAlphaImage.hdc, , , lWidth, lHeight
   
   ' Point byte arrays at the image bits for ease of
   ' manipulation of the data:
   Dim tMask As SAFEARRAY2D
   Dim bMask() As Byte
   Dim tImage As SAFEARRAY2D
   Dim bImage() As Byte
    
    With tMask
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_cMask.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = m_cMask.BytesPerScanLine()
        .pvData = m_cMask.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bMask()), VarPtr(tMask), 4
    
    With tImage
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_cAlphaImage.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = m_cAlphaImage.BytesPerScanLine()
        .pvData = m_cAlphaImage.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bImage()), VarPtr(tImage), 4
   
   Dim x As Long, y As Long
   Dim bAlpha As Long
   Dim lScanEnd As Long
   lScanEnd = (lWidth - 1) * 4
   
   For y = 0 To lHeight - 1
      For x = 0 To lScanEnd Step 4 ' each item has 4 bytes: B,G,R,A
         ' Get the red value from the mask to use as the alpha
         ' value:
         bAlpha = bMask(x, y)
         ' Set the alpha in the alpha image..
         bImage(x + 3, y) = bAlpha
         ' Now premultiply the b/g/r values by the alpha divided
         ' by 255.  This is required for the AlphaBlend GDI function,
         ' see MSDN/Platform SDK/GDI/BLENDFUNCTION for more
         ' details:
         bImage(x, y) = bImage(x, y) * bAlpha \ 255
         bImage(x + 1, y) = bImage(x + 1, y) * bAlpha \ 255
         bImage(x + 2, y) = bImage(x + 2, y) * bAlpha \ 255
      Next x
   Next y
   
   ' Clear up the temporary array descriptors.  You
   ' only need to do this on NT but best to be safe.
   CopyMemory ByVal VarPtrArray(bMask), 0&, 4
   CopyMemory ByVal VarPtrArray(bImage), 0&, 4
   
End Sub