vbAccelerator - Contents of code file: cTexturise.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cTexturise"
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 m_sTextureFile As String
Private m_cTexture As cDIBSection

Public Event Progress(ByVal lValue As Long, ByVal lMax As Long)

Public Function LoadTexture( _
      ByVal sTextureFile As String _
   ) As Boolean
Dim oPic As StdPicture
On Error GoTo LoadTextureError
   Set m_cTexture = New cDIBSection
   Set oPic = LoadPicture(sTextureFile)
   m_cTexture.CreateFromPicture oPic
   LoadTexture = True
   Exit Function
LoadTextureError:
   MsgBox "Failed to load texture '" & sTextureFile & "'", vbExclamation
End Function
Public Sub PaintTexture(ByVal lHDC As Long)
   If m_cTexture Is Nothing Then
      '
   ElseIf m_cTexture.Width = 0 Then
      '
   Else
      m_cTexture.PaintPicture lHDC
   End If
End Sub
Public Sub ApplyTexture( _
      ByRef cDibSrc As cDIBSection, _
      ByRef cDibDst As cDIBSection, _
      Optional ByVal lIntensity As Long = 100, _
      Optional ByVal lMidValue As Long = 0, _
      Optional ByVal lSaturation As Long = 100 _
   )
Dim bNo As Boolean
   If (m_cTexture Is Nothing) Then
      bNo = True
   End If
   If (m_cTexture.Width = 0) Then
      bNo = True
   End If
   If Not (bNo) Then
      ' do the processing:
      pApplyTexture cDibSrc, cDibDst, lIntensity, lMidValue, lSaturation
   Else
      ' copy src to out
      cDibSrc.PaintPicture cDibDst.hDC
   End If
End Sub
Private Sub pApplyTexture( _
      ByRef cDibSrc As cDIBSection, _
      ByRef cDibDst As cDIBSection, _
      Optional ByVal lIntensity As Long = 100, _
      Optional ByVal lMidValue As Long = 0, _
      Optional ByVal lSaturation As Long = 100 _
   )
Dim bDibSrc() As Byte
Dim tSASrc As SAFEARRAY2D
Dim bDibDst() As Byte
Dim tSADst As SAFEARRAY2D
Dim bDibTex() As Byte
Dim tSATex As SAFEARRAY2D
Dim x As Long, y As Long
Dim cx As Long, cy As Long
Dim tx As Long, ty As Long
Dim tcx As Long, tcy As Long
Dim lS As Long, fLightness As Single, fIntensity As Single
Dim fSaturation As Single
Dim fMidh As Single, fMids As Single, fMidl As Single
Dim fAmount As Single
Dim h As Single, s As Single, l As Single
Dim r As Long, g As Long, b As Long


   fIntensity = lIntensity / 100#
   RGBToHSL lMidValue, lMidValue, lMidValue, fMidh, fMids, fMidl
   fSaturation = lSaturation / 100#
   
   ' Get all the bits to work on:
   With tSASrc
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = cDibSrc.Height
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = cDibSrc.BytesPerScanLine
      .pvData = cDibSrc.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDibSrc()), VarPtr(tSASrc), 4
   
   With tSADst
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = cDibDst.Height
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = cDibDst.BytesPerScanLine
      .pvData = cDibDst.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDibDst()), VarPtr(tSADst), 4
   
   With tSATex
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = m_cTexture.Height
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = m_cTexture.BytesPerScanLine
      .pvData = m_cTexture.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDibTex()), VarPtr(tSATex), 4
   
   
   ' Get position information:
   tx = 0: ty = 0
   tcx = (m_cTexture.Width - 1) * 3
   tcy = m_cTexture.Height - 1
   cx = (cDibDst.Width - 1) * 3
   If (cx > (cDibSrc.Width - 1) * 3) Then cx = (cDibSrc.Width - 1) * 3
   cy = cDibDst.Height - 1
   If (cy > cDibSrc.Height - 1) Then cy = cDibSrc.Height - 1
   
   For y = 0 To cy
      For x = 0 To cx Step 3
         ' Set the destination to src with brightness adjusted
         ' to the texture:
         lS = bDibTex(tx, ty)
         RGBToHSL lS, lS, lS, h, s, fLightness
         fAmount = fLightness - fMidl
         r = bDibSrc(x + 2, y)
         g = bDibSrc(x + 1, y)
         b = bDibSrc(x, y)
         RGBToHSL r, g, b, h, s, l
         l = l * (1 + fAmount * fIntensity)
         If (l > 1) Then l = 1
         If (l < 0) Then l = 0
         s = s * fSaturation
         If (s > 1) Then s = 1
         If (s < 0) Then s = 0
         HLSToRGB h, s, l, r, g, b
         bDibDst(x + 2, y) = r
         bDibDst(x + 1, y) = g
         bDibDst(x, y) = b
         
         tx = tx + 3
         If (tx > tcx) Then tx = 0
      Next x
      RaiseEvent Progress(y, cy)
      ty = ty + 1: tx = 0
      If (ty > tcy) Then ty = 0
   Next y
   
   ' Clear up:
   CopyMemory ByVal VarPtrArray(bDibSrc), 0&, 4
   CopyMemory ByVal VarPtrArray(bDibDst), 0&, 4
   CopyMemory ByVal VarPtrArray(bDibTex), 0&, 4
   
End Sub

Public Property Get WithinTexture(ByVal x As Long, ByVal y As Long) As Boolean
   If Not m_cTexture Is Nothing Then
      WithinTexture = (x < m_cTexture.Width) And (x >= 0) And (y <=
       m_cTexture.Height) And (y >= 0)
   End If
End Property
Public Property Get TexturePixelColour(ByVal x As Long, ByVal y As Long) As Long
Dim bDibTex() As Byte
Dim tSATex As SAFEARRAY2D
Dim xi As Long
   
   If Not m_cTexture Is Nothing Then
      With tSATex
         .cbElements = 1
         .cDims = 2
         .Bounds(0).lLbound = 0
         .Bounds(0).cElements = m_cTexture.Height
         .Bounds(1).lLbound = 0
         .Bounds(1).cElements = m_cTexture.BytesPerScanLine
         .pvData = m_cTexture.DIBSectionBitsPtr
      End With
      CopyMemory ByVal VarPtrArray(bDibTex()), VarPtr(tSATex), 4
   
      xi = (x * 3) \ 3
      xi = xi * 3
      TexturePixelColour = RGB(bDibTex(xi + 2, y), bDibTex(xi + 1, y),
       bDibTex(xi, y))
   
      ' Clear up:
      CopyMemory ByVal VarPtrArray(bDibTex), 0&, 4
   End If
End Property