vbAccelerator - Contents of code file: cDIBShadowCreator.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cDIBShadowCreator"
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 "msvbvm50.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_cDIBSource As cAlphaDibSection
Private m_cDIBSourceScaled As cAlphaDibSection
Private m_cDIBResult As cAlphaDibSection
Private m_lMatrixSize As Long
Private m_lOffsetX As Long
Private m_lOffsetY As Long
Private m_oShadowColour As OLE_COLOR
Private m_oTransparentColour As OLE_COLOR
Private m_lSourceScale As Long
Private m_lOpacity As Long
Private m_bResizeToHoldShadow As Boolean

Public Property Get ResizeToHoldShadow() As Boolean
   ResizeToHoldShadow = m_bResizeToHoldShadow
End Property
Public Property Let ResizeToHoldShadow(ByVal value As Boolean)
   m_bResizeToHoldShadow = value
End Property

Public Property Get TransparentColor() As OLE_COLOR
   If (m_oTransparentColour = -1) Then
      If Not (m_cDIBSource Is Nothing) Then
         TransparentColor = GetPixelAPI(m_cDIBSource.hDC, 0, 0)
      Else
         TransparentColor = &HFFFFFF
      End If
   Else
      TransparentColor = m_oTransparentColour
   End If
End Property
Public Property Let TransparentColor(ByVal value As OLE_COLOR)
   m_oTransparentColour = value
   createScaledSource
End Property
Public Property Get ShadowColor() As OLE_COLOR
   ShadowColor = m_oShadowColour
End Property
Public Property Let ShadowColor(ByVal value As OLE_COLOR)
   m_oShadowColour = value
End Property
Public Property Get MatrixSize() As Long
   MatrixSize = m_lMatrixSize
End Property
Public Property Let MatrixSize(ByVal value As Long)
   m_lMatrixSize = value
End Property
Public Property Get OffsetX() As Long
   OffsetX = m_lOffsetX
End Property
Public Property Let OffsetX(ByVal value As Long)
   m_lOffsetX = value
End Property
Public Property Get OffsetY() As Long
   OffsetY = m_lOffsetY
End Property
Public Property Let OffsetY(ByVal value As Long)
   m_lOffsetY = value
End Property
Public Property Get Opacity() As Long
   Opacity = m_lOpacity
End Property
Public Property Let Opacity(ByVal value As Long)
   m_lOpacity = value
End Property

Public Property Get ScaledSourceDib() As cAlphaDibSection
   Set ScaledSourceDib = m_cDIBSourceScaled
End Property

Public Property Let DibSource(ByRef cDib As cAlphaDibSection)
   Set m_cDIBSource = cDib
   createScaledSource
End Property
Public Property Get DibResult() As cAlphaDibSection
   Set DibResult = m_cDIBResult
End Property

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

Private Sub createScaledSource()
   '
   If Not (m_cDIBSource Is Nothing) Then
      Dim lTransColor As Long
      If (m_oTransparentColour = -1) Then
         lTransColor = GetPixelAPI(m_cDIBSource.hDC, 0, 0)
      Else
         OleTranslateColor m_oTransparentColour, 0, lTransColor
      End If
      Dim cDibT As cAlphaDibSection
      Set cDibT = m_cDIBSource.Clone()
      cDibT.SetColourTransparent lTransColor, 255, True
      Dim lNewWidth As Long
      lNewWidth = m_cDIBSource.Width \ m_lSourceScale
      Set m_cDIBSourceScaled = cDibT.AlphaResample(lNewWidth)
      m_cDIBSourceScaled.PreMultiplyAlpha
   End If
   '
End Sub

Public Sub CreateShadow()
   '
Dim lWidth As Long
Dim lHeight As Long
Dim lOrgX As Long
Dim lOrgY As Long

   If (m_bResizeToHoldShadow) Then
      lWidth = m_cDIBSourceScaled.Width + Abs(m_lOffsetX) + (m_lMatrixSize + 1)
       * 2
      lHeight = m_cDIBSourceScaled.Height + Abs(m_lOffsetY) + (m_lMatrixSize +
       1) * 2
      If (m_lOffsetX < 0) Then
         lOrgX = Abs(m_lOffsetX)
      End If
      If (m_lOffsetY < 0) Then
         lOrgY = Abs(m_lOffsetY)
      End If
   Else
      lWidth = m_cDIBSourceScaled.Width
      lHeight = m_cDIBSourceScaled.Height
   End If

   Set m_cDIBResult = New cAlphaDibSection
   m_cDIBResult.Create lWidth, lHeight
   
   
   ' Create the shadow:
Dim tSA As SAFEARRAY2D
Dim tSATo As SAFEARRAY2D
Dim bDib() As Byte
Dim bDibTo() As Byte
Dim lX As Long
Dim lY As Long
Dim lFromX As Long
Dim lFromY As Long
Dim lAlpha As Long
Dim lShadowRed As Long
Dim lShadowGreen As Long
Dim lShadowBlue As Long
Dim xEnd As Long
Dim yEnd As Long
Dim xEndRes As Long
Dim yEndRes As Long
Dim x As Long
Dim y As Long
Dim xArrayStart As Long
Dim xArrayEnd As Long
Dim yArrayStart As Long
Dim yArrayEnd As Long
Dim lShadowColour As Long
Dim lDiv As Long
   
   OleTranslateColor m_oShadowColour, 0, lShadowColour
   lShadowRed = lShadowColour And &HFF&
   lShadowGreen = (lShadowColour And &HFF00&) \ &H100&
   lShadowBlue = (lShadowColour And &HFF0000) \ &H10000
   
   With tSA
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = m_cDIBSourceScaled.Height
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = m_cDIBSourceScaled.BytesPerScanLine()
      .pvData = m_cDIBSourceScaled.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
    
   With tSATo
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = m_cDIBResult.Height
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = m_cDIBResult.BytesPerScanLine()
      .pvData = m_cDIBResult.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDibTo()), VarPtr(tSATo), 4
   
   xEnd = m_cDIBSourceScaled.BytesPerScanLine - 4
   yEnd = m_cDIBSourceScaled.Height - 1
   xEndRes = m_cDIBResult.BytesPerScanLine - 4
   yEndRes = m_cDIBResult.Height - 1
   
   lDiv = (m_lMatrixSize * 2 + 1) * (m_lMatrixSize * 2 + 1)
   
   For lX = 0 To xEndRes Step 4
   
      lFromX = lX - IIf(m_lOffsetX > 0, m_lOffsetX, 0) * 4 - m_lMatrixSize * 4
      
      xArrayStart = lFromX - 4 * m_lMatrixSize
      If (xArrayStart < 0) Then
         xArrayStart = 0
      End If
      xArrayEnd = lFromX + 4 * m_lMatrixSize
      If (xArrayEnd > xEnd) Then
         xArrayEnd = xEnd
      End If
         
         
      For lY = 0 To yEndRes
      
         lFromY = lY + IIf(m_lOffsetY < 0, m_lOffsetY, 0) - m_lMatrixSize
                     
         yArrayStart = lFromY - m_lMatrixSize
         If (yArrayStart < 0) Then
            yArrayStart = 0
         End If
         yArrayEnd = lFromY + m_lMatrixSize
         If (yArrayEnd > yEnd) Then
            yArrayEnd = yEnd
         End If
               
         lAlpha = 0
            
         For x = xArrayStart To xArrayEnd Step 4
            For y = yArrayStart To yArrayEnd
               lAlpha = lAlpha + bDib(x + 3, y)
            Next y
         Next x
               
         lAlpha = lAlpha \ lDiv
         lAlpha = lAlpha * m_lOpacity \ 255
         
         bDibTo(lX, lY) = lShadowBlue * lAlpha \ 255
         bDibTo(lX + 1, lY) = lShadowGreen * lAlpha \ 255
         bDibTo(lX + 2, lY) = lShadowRed * lAlpha \ 255
         bDibTo(lX + 3, lY) = lAlpha
               
      Next lY
   
   Next lX
      
   
   CopyMemory ByVal VarPtrArray(bDibTo), 0&, 4
   CopyMemory ByVal VarPtrArray(bDib), 0&, 4
   
   
   ' Composite the scaled source over the top:
   lWidth = m_cDIBSourceScaled.Width
   lHeight = m_cDIBSourceScaled.Height
   If (lOrgX + lWidth) > m_cDIBResult.Width Then
      lWidth = m_cDIBResult.Width - lOrgX
   End If
   If (lOrgY + lHeight) > m_cDIBResult.Height Then
      lHeight = m_cDIBResult.Height - lOrgY
   End If
   m_cDIBSourceScaled.AlphaPaintPicture m_cDIBResult.hDC, lOrgX, lOrgY, lWidth,
    lHeight
   
   ' done
End Sub

Private Sub Class_Initialize()
   m_oTransparentColour = -1
   m_oShadowColour = &H808080
   m_lSourceScale = 1
   m_lOffsetX = 4
   m_lOffsetY = -4
   m_lMatrixSize = 3
   m_lOpacity = 128
   m_bResizeToHoldShadow = True
End Sub